(*
 * Copyright (C) 2003:
 *    Stefano Zacchiroli <zack@cs.unibo.it>
 *    for the HELM Team http://helm.cs.unibo.it/
 *
 *  This file is part of HELM, an Hypertextual, Electronic
 *  Library of Mathematics, developed at the Computer Science
 *  Department, University of Bologna, Italy.
 *
 *  HELM 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 2
 *  of the License, or (at your option) any later version.
 *
 *  HELM 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 HELM; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
 *  MA  02111-1307, USA.
 *
 *  For details, see the HELM World-Wide-Web page,
 *  http://helm.cs.unibo.it/
 *)

exception Impossible

let (profile_db : (string, Profile.t) Hashtbl.t) =
  try
    let ch = open_in Profile_manager_env.profile_db_path in
    input_value ch
  with
    _ -> Hashtbl.create 211

let get_param_opt (req : Http_types.request) p =
  try
    match req#param p with
      "" -> None
    | s -> Some s
  with
    Http_types.Param_not_found _ -> None

let new_key () =
  let hex_of_nibble n =
    if n >= 0 && n < 10 then
      string_of_int n
    else if n >= 10 && n < 16 then
      String.make 1 (Char.chr (n - 10 + (Char.code 'A')))
    else
      raise Impossible
  in
  let rec aux s =
    function
	0 -> s
      | n -> aux ((hex_of_nibble (Random.int 16)) ^ s) (n - 1)
  in
  aux "" 4

let new_unique_key =
  let rec aux () =
    let key = new_key () in
    if Hashtbl.mem profile_db key then
      aux ()
    else
      key
  in
  aux

let list_profiles () =
  let pl = ref [] in
  Hashtbl.iter
    (fun _ profile -> pl := (Profile.serialize profile false) :: !pl)
    profile_db ;
  "<profiles>" ^ (List.fold_left (^) "" !pl) ^ "</profiles>"

let get_profile id pwd =
  let profile = Hashtbl.find profile_db id in
  Profile.get profile pwd

let new_profile id pwd =
  match id with
    Some id' when Hashtbl.mem profile_db id' -> get_profile id' pwd
  | Some id' -> 
      let profile = Profile.create id' pwd in
      Hashtbl.add profile_db profile.Profile.id profile ;
      Profile.serialize profile true
  | None ->
      let profile = Profile.create (new_unique_key ()) None in
      Hashtbl.add profile_db profile.Profile.id profile ;
      Profile.serialize profile true

let set_profile id field value pwd =
  let profile = Hashtbl.find profile_db id in
  Profile.set profile field value pwd

let del_profile id pwd =
  let profile = Hashtbl.find profile_db id in
  let res = Profile.del profile pwd in
  Hashtbl.remove profile_db id ;
  res

let set_password id new_pwd pwd =
  let profile = Hashtbl.find profile_db id in
  Profile.set_password profile new_pwd pwd

let set_access id read_access write_access profile_access pwd =
  let profile = Hashtbl.find profile_db id in
  Profile.set_access profile read_access write_access profile_access pwd

let callback (req : Http_types.request) outchan =
  let res = 
    try
      prerr_endline ("Connection from " ^ req#clientAddr) ;
      prerr_endline ("Received request: " ^ req#path) ;
      begin
	match req#path with
	  "/list" -> list_profiles ()
	| "/get" ->
	    let id = req#param "id"
	    and pwd = get_param_opt req "password" in
	    get_profile id pwd
	| "/set" ->
	    let id = req#param "id"
	    and field = req#param "field"
	    and value = get_param_opt req "value"
	    and pwd = get_param_opt req "password" in
	    set_profile id field value pwd
	| "/del" ->
	    let id = req#param "id"
	    and pwd = get_param_opt req "password" in
	    del_profile id pwd
	| "/new" ->
	    let id = get_param_opt req "id"
	    and pwd = get_param_opt req "password" in
	    new_profile id pwd
	| "/password" ->
	    let id = req#param "id"
	    and old_pwd = get_param_opt req "old_password"
	    and new_pwd = get_param_opt req "new_password" in
	    set_password id new_pwd old_pwd
	| "/access" ->
	    let id = req#param "id"
	    and pwd = get_param_opt req "password"
	    and read_access = get_param_opt req "read"
	    and write_access = get_param_opt req "write"
	    and profile_access = get_param_opt req "profile" in
	    set_access id read_access write_access profile_access pwd
	| s -> Response.error ("unrecognized command: " ^ s)
      end
    with
      Not_found -> Response.error "unknown profile"
    | Profile.Permission_denied -> Response.error "permission denied"
    | e -> Response.error ("uncaught exception: " ^ (Printexc.to_string e))
  in
  Http_daemon.respond
    ~body:res ~headers:["Content-Type", "text/xml"] outchan

    (* daemon initialization *)

let save_db () =
  let ch = open_out Profile_manager_env.profile_db_path in
  output_value ch profile_db ;
  close_out ch

let main () =
  at_exit save_db ;
  Sys.catch_break true ;
  try
    Http_daemon.start' ~timeout:(Some 600) ~port:58099 ~mode:`Thread callback
  with
    Sys.Break -> ()
in
main ()