(* O'Caml Freenet Client Protocol client module                     *)
(* by Travis Bemann                                                 *)
(*                                                                  *)
(* 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.              *)

type field_val =
    Field_string of string
  | Field_fieldset of fieldset
and field =
    {name : string; mutable content : field_val}
and fieldset =
    field list;;

let field_of_name (f : fieldset) n =
  List.find (fun i -> i.name = n) f;;

let path_split p =
  try
    let o = String.index p '.' in
    String.sub p 0 o,
    String.sub p (o + 1) ((String.length p) - (o + 1))
  with
    Not_found ->
      raise (Failure "No . in string")

let rec field_of_path (f : fieldset) n =
  try
    let d, p = path_split n in
    if ((String.length d) <> 0) && ((String.length p) <> 0) then
      match (field_of_name f d).content with
	Field_fieldset s ->
	  field_of_path s p
      | Field_string x ->
	  raise Not_found
    else
      raise Not_found
  with
    Failure "No . in string" ->
      field_of_name f n;;

let has_field f n = 
  try ignore (field_of_path f n); true
  with Not_found -> false

let string_of_field f =
  match f.content with
    Field_string s ->
      s
  | Field_fieldset x ->
      raise (Failure "Field is not a string");;

let int_of_field f =
  Strutil.int_of_hex (string_of_field f);;

let fieldset_of_field f =
  match f.content with
    Field_fieldset s ->
      s
  | Field_string x ->
      raise (Failure "Field is not a fieldset");;

let field_val_of_int n =
  Field_string (Printf.sprintf "%x" n);;

exception Already_exists;;

let rec field_make (f : fieldset) n v =
  try
    let d, p = path_split n in
    try
      let fi = field_of_name f d in
      match fi.content with
	Field_fieldset s ->
	  fi.content <- Field_fieldset (field_make s p v);
	  f
      |	Field_string x ->
	  raise Already_exists
    with
      Not_found ->
	{name = d; content = Field_fieldset (field_make [] p v)} :: f
  with
    Failure m ->
      try
	let fi = field_of_name f n in
	raise Already_exists
      with
	Not_found ->
	  {name = n; content = v} :: f;;

let rec fields_make fieldset items =
  match items with
    (name, v) :: rest -> fields_make (field_make fieldset name v) rest
  | [] -> fieldset

let fields_parse d =
  let rec fields_parse_step d f =
    let l, r =
      try
	let o = String.index d '\n' in
	if o <> 0 then
	  begin
	    if (String.get d (o - 1)) <> '\r' then
	      String.sub d 0 o
	    else
	      String.sub d 0 (o - 1)
	  end, String.sub d (o + 1) ((String.length d) - (o + 1))
	else
	  "", String.sub d 1 ((String.length d) - 1)
      with
	Not_found ->
	  d, ""
    in
    if l <> "" then
      try
	let o = String.index l '=' in
	let p = Strutil.strip (String.sub l 0 o)
	and v = Strutil.strip (String.sub l (o + 1)
				 ((String.length l) - (o + 1))) in
	try
	  fields_parse_step r (field_make f p (Field_string v))
	with
	  Already_exists ->
	    if r <> "" then
	      fields_parse_step r f
	    else
	      f
      with
	Not_found ->
	  if r <> "" then
	    fields_parse_step r f
	  else
	    f
    else
      if r <> "" then
	fields_parse_step r f
      else
	f
  in
  fields_parse_step d [];;

let field_list_parse l =
  let rec field_list_parse_step l f =
    match l with
      x :: y ->
	begin
	  try
	    let o = String.index x '=' in
	    let p = Strutil.strip (String.sub x 0 o)
	    and v = Strutil.strip (String.sub x (o + 1)
				     ((String.length x) - (o + 1))) in
	    begin
	      try
		field_list_parse_step y (field_make f p (Field_string v))
	      with
		Already_exists ->
		  field_list_parse_step y f
	    end
	  with
	    Not_found ->
	      field_list_parse_step y f
	end
    | [] ->
	f
  in
  field_list_parse_step l [];;

let fields_print f =
  let rec fields_print_step f n b =
    List.iter
      begin
	fun i ->
	  match i.content with
	    Field_string d ->
	      Buffer.add_string b (Printf.sprintf "%s%s=%s\n" n i.name d)
	  | Field_fieldset fn ->
	      fields_print_step fn (Printf.sprintf "%s%s." n i.name) b
      end
      f
  in
  let b = Buffer.create 1 in
  fields_print_step f "" b;
  Buffer.contents b;;

let rec fieldset_list_merge l =
  let rec fieldset_merge_step l c =
    match l with
      x :: y ->
	begin
	  match x.content with
	    Field_string s ->
	      fieldset_merge_step y (field_make c x.name x.content)
	  | Field_fieldset f ->
	      begin
		try
		  let z = field_of_name c x.name in
		  begin
		    match z.content with
		      Field_fieldset fo ->
			z.content <-
			  Field_fieldset (fieldset_list_merge [fo; f]);
			fieldset_merge_step y c
		    | Field_string s ->
			fieldset_merge_step y c
		  end
		with
		  Not_found ->
		    fieldset_merge_step y
		      (field_make c x.name
			 (Field_fieldset (fieldset_merge_step f [])))
	      end
	end
    | [] ->
	c
  and tail_merge l c =
    match l with
      [] :: x ->
	tail_merge x c
    | (x :: y) :: z ->
	tail_merge (y :: z) (x :: c)
    | [] ->
	c
  in
  fieldset_merge_step (tail_merge l []) [];;