(* Ethel - An OCaml Freenet Daemon                                  *)
(* by Travis Bemann and Eric Norige                                 *)
(*                                                                  *)
(* This program is free software; you can redistribute it and/or    *)
(* modify it under the terms of the GNU Lesser General Public       *)
(* License as published by the Free Software Foundation; either     *)
(* version 2 of the License, or (at your option) any later version. *)
(*                                                                  *)
(* This program 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 Lesser General Public License for more details.              *)

open Str
open Strutil

exception Config_error of string
exception Cannot_open_any_config
exception Cannot_open_config

type config_data =
    Config_string of string
  | Config_bool of bool
  | Config_int of int
  | Config_float of float
  | Config_list of config_data list
  | Config_null

let string_of_config = function
    Config_string string -> string
  | _ -> raise (Failure "Config.string_of_config")

let bool_of_config = function
    Config_bool bool -> bool
  | _ -> raise (Failure "Config.bool_of_config")

let int_of_config = function
    Config_int n -> n
  | _ -> raise (Failure "Config.int_of_config")

let float_of_config = function
    Config_float n -> n
  | _ -> raise (Failure "Config.float_of_config")

let string_opt_of_config = function
    Config_string string -> Some string
  | Config_null -> None
  | _ -> raise (Failure "Config.string_opt_of_config")

let int_opt_of_config = function
    Config_int n -> Some n
  | Config_null -> None
  | _ -> raise (Failure "Config.int_opt_of_config")

let float_opt_of_config = function
    Config_float n -> Some n
  | Config_null -> None
  | _ -> raise (Failure "Config.float_opt_of_config")

type token =
    Name of string
  | String of string
  | Int of int
  | Float of float
  | Equal
  | List_begin
  | List_sep
  | List_end

let rec parse_list tokens acc =
  match tokens with
    List_end :: tokens ->
      (Config_list (List.rev acc), tokens)
  | Equal :: _ | List_sep :: _ ->
      raise (Config_error "Invalid list")
  | _ ->
      let item, tokens = parse_data tokens in
      let acc = item :: acc in
      match tokens with
	List_sep :: tokens -> parse_list tokens acc
      | List_end :: tokens ->
	  (Config_list (List.rev acc), tokens)
      | _ -> raise (Config_error "Invalid list")
	    
and parse_data tokens =
  match tokens with
    String string :: tokens -> (Config_string string, tokens)
  | Int n :: tokens ->
      begin match tokens with
	suffix :: rest ->
	  begin match suffix with
	    Name "k" | Name "K" | Name "kb" | Name "Kb" |
	    Name "KB" | Name "kB" ->
	      (Config_int (n * 1024), rest)
	  | Name "m" | Name "M" | Name "mb" | Name "MB" ->
	      (Config_int (n * (1024 * 1024)), rest)
	  | Name "g" | Name "G" | Name "gb" | Name "GB" ->
	      (Config_int (n * (1024 * 1024 * 1024)), rest)
	  | Name "t" | Name "T" | Name "tb" | Name "TB" ->
	      (Config_int (n * (1024 * 1024 * 1024 * 1024)),
	       rest)
	  | _ -> (Config_int n, tokens)
	  end
      | [] -> (Config_int n, tokens)
      end
  | Float n :: tokens ->
      begin match tokens with
	suffix :: rest ->
	  begin match suffix with
	    Name "k" | Name "K" | Name "kb" | Name "Kb" |
	    Name "KB" | Name "kB" ->
	      (Config_int (int_of_float (n *. 1024.0)), rest)
	  | Name "m" | Name "M" | Name "mb" | Name "MB" ->
	      (Config_int
		 (int_of_float (n *. (1024.0 ** 2.0))),
	       rest)
	  | Name "g" | Name "G" | Name "gb" | Name "GB" ->
	      (Config_int
		 (int_of_float (n *. (1024.0 ** 3.0))),
	       rest)
	  | Name "t" | Name "T" | Name "tb" | Name "TB" ->
	      (Config_int
		 (int_of_float (n *. (1024.0 ** 4.0))),
	       rest)
	  | _ -> (Config_float n, tokens)
	  end
      | [] -> (Config_float n, tokens)
      end
  | List_begin :: tokens ->
      parse_list tokens []
  | Name name :: tokens ->
      begin match name with
	"null" | "none" | "nil" | "zilch" | "frotz" | "frobnitz"
      | "frobozz" | "frobbotzim" | "lart" | "luser" | "bofh"
      | "fubar" | "frotzed" | "munge" | "mangle" | "kill"
      | "why_the_fuck_are_there_so_many_names_for_null" ->
	  (Config_null, tokens)
      | "true" | "on" -> (Config_bool true, tokens)
      | "false" | "off" -> (Config_bool false, tokens)
      | _ -> raise (Config_error "Invalid value")
      end
  | _ -> raise (Config_error "Invalid value")
	
let tokenize_name data off =
  let len = String.length data in
  let rec step off =
    if off < len then
      match String.get data off with
	'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' ->
	  step (off + 1)
      | ' ' | '\t' | '\n' | '\r' | '=' | '[' | ',' | ']' -> off
      | _ -> raise (Config_error "Invalid name token")
    else off
  in
  let off_end = step off in
  (Name (String.sub data off (off_end - off)), off_end)
    
let tokenize_string data off =
  let len = String.length data
  and buf = Buffer.create 0 in
  let rec step off =
    if off < len then
      match String.get data off with
	'\\' ->
	  if off + 1 < len then
	    match String.get data (off + 1) with
	      'n' ->
		Buffer.add_char buf '\n';
		step (off + 2)
	    | 'r' ->
		Buffer.add_char buf '\r';
		step (off + 2)
	    | 't' ->
		Buffer.add_char buf '\t';
		step (off + 2)
	    | '"' ->
		Buffer.add_char buf '"';
		step (off + 2)
	    | 'x' -> escape_hex (off + 2)
	    | 'o' -> escape_oct (off + 2)
	    | 'd' -> escape_dec (off + 2)
	    | 'b' -> escape_bin (off + 2)
	    | _ -> raise (Config_error "Invalid escape")
	  else raise (Config_error "Unclosed string")
      | '"' -> off + 1
      | '\n' -> step (off + 1)
      | char ->
	  Buffer.add_char buf char;
	  step (off + 1)
    else raise (Config_error "Unclosed string")
  and escape_hex off =
    if off < len then
      try
	let hex = String.sub data off 2 in
	let ascii = int_of_string ("0x" ^ hex) in
	Buffer.add_char buf (char_of_int ascii);
	step (off + 2)
      with Failure _ ->
	raise (Config_error "Invalid hexadecimal escape")
    else raise (Config_error "Unclosed string")
  and escape_oct off =
    if off < len then
      try
	let oct = String.sub data off 3 in
	let ascii = int_of_string ("0o" ^ oct) in
	Buffer.add_char buf (char_of_int ascii);
	step (off + 3)
      with Failure _ ->
	raise (Config_error "Invalid hexadecimal escape")
    else raise (Config_error "Unclosed string")
  and escape_dec off =
    if off < len then
      try
	let dec = String.sub data off 3 in
	let ascii = int_of_string dec in
	Buffer.add_char buf (char_of_int ascii);
	step (off + 3)
      with Failure _ ->
	raise (Config_error "Invalid hexadecimal escape")
    else raise (Config_error "Unclosed string")
  and escape_bin off =
    if off < len then
      try
	let bin = String.sub data off 8 in
	let ascii = int_of_string ("0b" ^ bin) in
	Buffer.add_char buf (char_of_int ascii);
	step (off + 8)
      with Failure _ ->
	raise (Config_error "Invalid hexadecimal escape")
    else raise (Config_error "Unclosed string")
  in
  let off_end = step off in
  (String (Buffer.contents buf), off_end)
    
let tokenize_number data off =
  let len = String.length data in
  let rec step off is_float =
    if off < len then
      match String.get data off with
	'0' .. '9' | '-' -> step (off + 1) is_float
      | '.' ->
	  if not is_float then
	    step (off + 1) true
	  else
	    raise (Config_error "Invalid number")
      | 'x' | 'o' | 'b' ->
	  if not is_float then
	    step (off + 1) false
	  else
	    raise (Config_error "Invalid number")
      | ' ' | '\t' | '\n' | '\r' | '=' | '[' | ',' | ']' ->
	  (off, is_float)
      | _ -> raise (Config_error "Invalid name token")
    else (off, is_float)
  in
  let off_end, is_float = step off false in
  let item = String.sub data off (off_end - off) in
  let token =
    if is_float then
      try Float (float_of_string item)
      with Failure _ -> raise (Config_error "Invalid number")
    else
      try Int (int_of_string item)
      with Failure _ -> raise (Config_error "Invalid number")
  in (token, off_end)
    
let rec line_comment data off =
  if off < String.length data then
    match String.get data off with
      '\n' | '\r' -> off
    | _ -> line_comment data (off + 1)
  else
    off
      
let tokenize data =
  let len = String.length data in
  let rec step off tokens =
    if off < len then
      let start = String.get data off in
      match start with
	' ' | '\t' | '\n' | '\r' -> step (off + 1) tokens
      | '#' -> step (line_comment data off) tokens
      | _ ->
	  let token, off = match start with
	    'a' .. 'z' | 'A' .. 'Z' | '_' ->
	      tokenize_name data off
	  | '"' -> tokenize_string data (off + 1)
	  | '0' .. '9' | '-' -> tokenize_number data off
	  | '=' -> (Equal, off + 1)
	  | '[' -> (List_begin, off + 1)
	  | ',' -> (List_sep, off + 1)
	  | ']' -> (List_end, off + 1)
	  | _ -> raise (Config_error "Invalid token")
	  in step off (token :: tokens)
    else List.rev tokens
  in step 0 []

let escape_char = function
    '\n' -> "\\n"
  | '\r' -> "\\r"
  | '\t' -> "\\t"
  | '"' -> "\\\""
  | char -> Printf.sprintf "\\x%02X" (int_of_char char)

let format_string string escape_high =
  let len = String.length string in
  let buf = Buffer.create (len + 2) in
  let rec step off =
    if off < len then
      let char = String.get string off in
      let code = int_of_char char in
      if (code < 0x20) || (code = 0x7F) || (char = '"') then
	Buffer.add_string buf (escape_char char)
      else if (code > 0x7F) && escape_high then
	Buffer.add_string buf (escape_char char)
      else Buffer.add_char buf char;
      step (off + 1)
    else ()
  in
  Buffer.add_char buf '"';
  step 0;
  Buffer.add_char buf '"';
  Buffer.contents buf

let rec format_list list escape_high =
  Printf.sprintf "[%s]"
    (String.concat ", "
       (List.rev
	  (List.rev_map
	     (fun data -> format_data data escape_high)
	     list)))

and format_data data escape_high =
  match data with
    Config_null -> "null"
  | Config_bool true -> "true"
  | Config_bool false -> "false"
  | Config_int n -> string_of_int n
  | Config_float n -> string_of_float n
  | Config_string string -> format_string string escape_high
  | Config_list list -> format_list list escape_high

let format_item (name, data, default) escape_high =
  Printf.sprintf "%s%s = %s\n"
    (if default then "#" else "")
    name
    (format_data data escape_high)

let format_items items escape_high =
  String.concat ""
    (List.rev
       (List.rev_map (fun item -> format_item item escape_high)
	  items))

let copy_hash hash =
  let hash_new = Hashtbl.create 0 in
  Hashtbl.iter
    (fun field data -> Hashtbl.add hash_new field data)
    hash;
  hash_new
    
class configure ~defaults ~files ~required =
  object (self : 'a)
    val hash = Hashtbl.create 0
    val items = []
    method field name = Hashtbl.find hash name
    method field_string name = string_of_config (self#field name)
    method field_bool name = bool_of_config (self#field name)
    method field_int name = int_of_config (self#field name)
    method field_float name = float_of_config (self#field name)
    method field_string_opt name = string_opt_of_config (self#field name)
    method field_int_opt name = int_opt_of_config (self#field name)
    method field_float_opt name = float_opt_of_config (self#field name)
    method dump =
      let fields = ref [] in
      Hashtbl.iter
	(fun field data -> fields := (field, data) :: !fields)
	hash;
      !fields
    method private parse file default =
      let len = in_channel_length file in
      let data = String.create len in
      really_input file data 0 len;
      let tokens = tokenize data in
      if not default then
	self#parse_tokens tokens
      else self#parse_tokens_default tokens
    method private set_field field data =
      begin try
	let _ = Hashtbl.find hash field in
	Hashtbl.remove hash field
      with Not_found -> ()
      end;
      Hashtbl.add hash field data
    method private set_field_default field data =
      try let _ = Hashtbl.find hash field in ()
      with Not_found -> Hashtbl.add hash field data
    method private parse_tokens tokens =
      match tokens with
	Name field :: tokens ->
	  begin match tokens with
	    Equal :: tokens ->
	      let data, tokens = parse_data tokens in
	      self#set_field field data;
	      self#parse_tokens tokens
	  | _ -> raise (Config_error "Syntax error")
	  end
      | [] -> ()
      | _ -> raise (Config_error "Syntax error")
    method private parse_tokens_default tokens =
      match tokens with
	Name field :: tokens ->
	  begin match tokens with
	    Equal :: tokens ->
	      let data, tokens = parse_data tokens in
	      self#set_field_default field data;
	      self#parse_tokens tokens
	  | _ -> raise (Config_error "Syntax error")
	  end
      | [] -> ()
      | _ -> raise (Config_error "Syntax error")
    method add_fields fields =
      let hash_new = Hashtbl.create 0 in
      List.iter
	(fun (field, data) -> Hashtbl.add hash_new field data) fields;
      Hashtbl.iter
	begin fun field data ->
	  try let _ = Hashtbl.find hash_new field in ()
	  with Not_found -> Hashtbl.add hash_new field data
	end
	hash;
      {< hash = hash_new >}
    method add_fields_default fields =
      let hash_new = copy_hash hash in
      List.iter
	begin fun (field, data) ->
	  try
	    let _ = Hashtbl.find hash_new field in ()
	  with Not_found -> Hashtbl.add hash_new field data
	end
	fields;
      {< hash = hash_new >}
    method merge (conf : configure) =
      self#add_fields conf#dump
    method merge_default (conf : configure) =
      self#add_fields_default conf#dump
    method load files =
      let conf = {< hash = copy_hash hash >} in
      conf#load_dirty files false;
      conf
    method load_required files =
      let conf = {< hash = copy_hash hash >} in
      conf#load_dirty files true;
      conf
    method load_dirty files required =
      if files <> [] then
	let success =
	  List.fold_left
	    begin fun success file ->
	      try
		let file = open_in file in
		self#parse file false;
		close_in file;
		true
	      with Sys_error _ -> success
	    end
	    false files
	in
	if (not success) && required then
	  if List.length files > 1 then
	    raise Cannot_open_any_config
	  else if List.length files = 1 then
	    raise Cannot_open_config
	  else ()
	else ()
    method dump_format ~sort ~defaults ~escape_high =
      let items = List.rev_map
	  begin fun (name, data) ->
	    try
	      let _, default_data = List.find
		  (fun (default_name, _) -> name = default_name)
		  defaults in
	      (name, data, data = default_data)
	    with Not_found -> (name, data, false)
	  end
	  self#dump in
      let items = List.sort
	  (fun (name0, _, _) (name1, _, _) -> sort name0 name1)
	  items in
      format_items items escape_high
    initializer
      List.iter (fun (field, data) -> self#set_field field data)
	defaults;
      self#load_dirty files required
  end