helm/DEVEL/profile-manager/profile.ml

   1
   2 exception Permission_denied
   3 exception Invalid_access of string
   4
   5 type access_t =
   6     Allowed
   7   | Denied
   8   | Password
   9
  10 let access_of_string old =
  11   function
  12       None -> old
  13     | Some "allowed" -> Allowed
  14     | Some "denied" -> Denied
  15     | Some "password" -> Password
  16     | Some s -> raise (Invalid_access s)
  17
  18 let string_of_access =
  19   function
  20       Allowed -> "allowed"
  21     | Denied -> "denied"
  22     | Password -> "password"
  23
  24 type t =
  25     { id : string;
  26       mutable password : string;
  27       mutable read_access : access_t;
  28       mutable write_access : access_t;
  29       mutable profile_access : access_t;
  30       data : (string, string) Hashtbl.t;
  31     }
  32
  33 let serialize profile with_data =
  34   let serialize_data data =
  35     let sl = ref [] in
  36     Hashtbl.iter
  37       (fun field value ->
  38         sl := ("  <field id=\"" ^ (Response.quote_attribute field) ^ "\">" ^ (Response.quote value) ^ "</field>\n")::!sl)
  39       data ;
  40     List.fold_left (^) "" !sl
  41   in
  42   "<profile id=\"" ^ profile.id ^
  43   "\" read=\"" ^ (string_of_access profile.read_access) ^
  44   "\" write=\"" ^ (string_of_access profile.write_access) ^
  45   "\" profile=\"" ^ (string_of_access profile.profile_access) ^
  46   "\">\n" ^ (if with_data then serialize_data profile.data else "") ^ "</profile>"
  47
  48 let create key pwd =
  49   let access, pwd' =
  50     match pwd with
  51       Some s -> Password, s
  52     | None -> Allowed, ""
  53   in
  54   let profile =
  55     { id = key;
  56       password = pwd';
  57       read_access = access;
  58       write_access = access;
  59       profile_access = access;
  60       data = Hashtbl.create 11
  61     }
  62   in
  63   profile
  64
  65 let test_read_access profile pwd =
  66   match pwd, profile.read_access with
  67     Some s, Password when s = profile.password -> ()
  68   | None, Password when profile.password = "" -> ()
  69   | _, Allowed -> ()
  70   | _ -> raise Permission_denied
  71
  72 let test_write_access profile pwd =
  73   match pwd, profile.write_access with
  74     Some s, Password when s = profile.password -> ()
  75   | None, Password when profile.password = "" -> ()
  76   | _, Allowed -> ()
  77   | _ -> raise Permission_denied
  78
  79 let test_profile_access profile pwd =
  80   match pwd, profile.profile_access with
  81     Some s, Password when s = profile.password -> ()
  82   | None, Password when profile.password = "" -> ()
  83   | _, Allowed -> ()
  84   | _ -> raise Permission_denied
  85
  86 let get profile pwd =
  87   test_read_access profile pwd ;
  88   serialize profile true
  89
  90 let set profile field value pwd =
  91   test_write_access profile pwd ;
  92   begin
  93     match value with
  94       Some value' -> Hashtbl.replace profile.data field value'
  95     | None -> Hashtbl.remove profile.data field
  96   end ;
  97   Response.ok ()
  98
  99 let del profile pwd =
 100   test_profile_access profile pwd ;
 101   Response.ok ()
 102
 103 let set_password profile new_pwd pwd =
 104   test_profile_access profile pwd ;
 105   let new_pwd' =
 106     match new_pwd with
 107       Some s -> s
 108     | None -> ""
 109   in
 110   prerr_endline ("old " ^ profile.password ^ " new " ^ new_pwd') ;
 111   profile.password <- new_pwd' ;
 112   Response.ok ()
 113
 114 let set_access profile read_access write_access profile_access pwd =
 115   test_profile_access profile pwd ;
 116   profile.read_access <- access_of_string profile.read_access read_access ;
 117   profile.write_access <- access_of_string profile.write_access write_access ;
 118   profile.profile_access <- access_of_string profile.profile_access profile_access ;
 119   Response.ok ()