exception Permission_denied
exception Invalid_access of string

type access_t =
    Allowed
  | Denied
  | Password

let access_of_string old =
  function
      None -> old
    | Some "allowed" -> Allowed
    | Some "denied" -> Denied
    | Some "password" -> Password
    | Some s -> raise (Invalid_access s)

let string_of_access =
  function
      Allowed -> "allowed"
    | Denied -> "denied"
    | Password -> "password"

type t =
    { id : string;
      mutable password : string;
      mutable read_access : access_t;
      mutable write_access : access_t;
      mutable profile_access : access_t;
      data : (string, string) Hashtbl.t;
    }

let serialize profile with_data =
  let serialize_data data =
    let sl = ref [] in
    Hashtbl.iter
      (fun field value ->
	sl := ("  <field id=\"" ^ (Response.quote_attribute field) ^ "\">" ^ (Response.quote value) ^ "</field>\n")::!sl)
      data ;
    List.fold_left (^) "" !sl
  in
  "<profile id=\"" ^ profile.id ^
  "\" read=\"" ^ (string_of_access profile.read_access) ^
  "\" write=\"" ^ (string_of_access profile.write_access) ^
  "\" profile=\"" ^ (string_of_access profile.profile_access) ^
  "\">\n" ^ (if with_data then serialize_data profile.data else "") ^ "</profile>"

let create key pwd =
  let access, pwd' =
    match pwd with
      Some s -> Password, s
    | None -> Allowed, ""
  in
  let profile =
    { id = key;
      password = pwd';
      read_access = access;
      write_access = access;
      profile_access = access;
      data = Hashtbl.create 11
    }
  in
  profile

let test_read_access profile pwd =
  match pwd, profile.read_access with
    Some s, Password when s = profile.password -> ()
  | None, Password when profile.password = "" -> ()
  | _, Allowed -> ()
  | _ -> raise Permission_denied

let test_write_access profile pwd =
  match pwd, profile.write_access with
    Some s, Password when s = profile.password -> ()
  | None, Password when profile.password = "" -> ()
  | _, Allowed -> ()
  | _ -> raise Permission_denied

let test_profile_access profile pwd =
  match pwd, profile.profile_access with
    Some s, Password when s = profile.password -> ()
  | None, Password when profile.password = "" -> ()
  | _, Allowed -> ()
  | _ -> raise Permission_denied

let get profile pwd =
  test_read_access profile pwd ;
  serialize profile true

let set profile field value pwd =
  test_write_access profile pwd ;
  begin
    match value with
      Some value' -> Hashtbl.replace profile.data field value'
    | None -> Hashtbl.remove profile.data field
  end ;
  Response.ok ()

let del profile pwd =
  test_profile_access profile pwd ;
  Response.ok ()

let set_password profile new_pwd pwd =
  test_profile_access profile pwd ;
  let new_pwd' =
    match new_pwd with
      Some s -> s
    | None -> ""
  in
  prerr_endline ("old " ^ profile.password ^ " new " ^ new_pwd') ;
  profile.password <- new_pwd' ;
  Response.ok ()

let set_access profile read_access write_access profile_access pwd =
  test_profile_access profile pwd ;
  profile.read_access <- access_of_string profile.read_access read_access ;
  profile.write_access <- access_of_string profile.write_access write_access ;
  profile.profile_access <- access_of_string profile.profile_access profile_access ;
  Response.ok ()