helm/uwobo/uwobo_profiles.ml

   1 (*
   2  * Copyright (C) 2004:
   3  *    Stefano Zacchiroli <zack@cs.unibo.it>
   4  *    for the HELM Team http://helm.cs.unibo.it/
   5  *
   6  *  This file is part of HELM, an Hypertextual, Electronic
   7  *  Library of Mathematics, developed at the Computer Science
   8  *  Department, University of Bologna, Italy.
   9  *
  10  *  HELM is free software; you can redistribute it and/or
  11  *  modify it under the terms of the GNU General Public License
  12  *  as published by the Free Software Foundation; either version 2
  13  *  of the License, or (at your option) any later version.
  14  *
  15  *  HELM is distributed in the hope that it will be useful,
  16  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18  *  GNU General Public License for more details.
  19  *
  20  *  You should have received a copy of the GNU General Public License
  21  *  along with HELM; if not, write to the Free Software
  22  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  23  *  MA  02111-1307, USA.
  24  *
  25  *  For details, see the HELM World-Wide-Web page,
  26  *  http://helm.cs.unibo.it/
  27  *)
  28
  29 type profile_id = string
  30
  31 let profiles = "profiles"
  32
  33 let profile_key pid =
  34   profiles ^ "." ^ pid
  35
  36 let string_of_permission =
  37  function
  38    `Read -> "read"
  39   | `Write -> "write"
  40   | `Admin -> "admin"
  41
  42 let permission_key for_what pid =
  43  profile_key pid ^ ".permissions." ^ (string_of_permission for_what)
  44
  45 let read_permission_key = permission_key `Read
  46 let write_permission_key = permission_key `Write
  47 let admin_permission_key = permission_key `Admin
  48
  49 let password_key pid =
  50   profile_key pid ^ ".password"
  51
  52 let params_key pid =
  53   profile_key pid ^ ".params"
  54
  55 let param_key pid param =
  56   params_key pid ^ "." ^ param
  57
  58 exception Access_denied of string * profile_id
  59 exception Profile_exists of profile_id
  60 exception Impossible
  61
  62 let new_key () =
  63   let hex_of_nibble n =
  64     if n >= 0 && n < 10 then
  65       string_of_int n
  66     else if n >= 10 && n < 16 then
  67       String.make 1 (Char.chr (n - 10 + (Char.code 'A')))
  68     else
  69       raise Impossible
  70   in
  71   let rec aux s =
  72     function
  73         0 -> s
  74       | n -> aux ((hex_of_nibble (Random.int 16)) ^ s) (n - 1)
  75   in
  76   aux "" 4
  77
  78 let create_fresh_id =
  79   let rec aux () =
  80     let key = new_key () in
  81     if Helm_registry.has (read_permission_key key) then
  82       aux ()
  83     else
  84       key
  85   in
  86   aux
  87
  88 let list () = fst (Helm_registry.ls profiles)
  89
  90 let to_list_rel ~prefix () =
  91  List.map (fun (key,value) -> Pcre.replace ~pat:("^" ^ Pcre.quote (prefix ^ ".")) key, value)
  92   (Helm_registry.to_list ~prefix ())
  93
  94 let check_permission pid password for_what =
  95   match password, Helm_registry.get_bool (permission_key for_what pid) with
  96       _, true -> ()
  97     | Some pwd, false when Some pwd = Helm_registry.get_opt Helm_registry.get (password_key pid) -> ()
  98     | _ -> raise (Access_denied (string_of_permission for_what, pid))
  99
 100 let create ?id ?clone ?clone_password ?(read_perm=true) ?(write_perm=true) ?(admin_perm=true) ?password () =
 101   let pid =
 102     match id with
 103         None -> create_fresh_id ()
 104       | Some pid when Helm_registry.has (read_permission_key pid) -> raise (Profile_exists pid)
 105       | Some pid -> pid
 106   in
 107   let params =
 108     match clone with
 109         None -> []
 110       | Some pid ->
 111           check_permission pid clone_password `Read ;
 112           to_list_rel ~prefix:(params_key pid) ()
 113   in
 114     List.iter (fun (key, value) -> Helm_registry.set_string (params_key pid ^ "." ^ key) value) params ;
 115     Helm_registry.set_bool (read_permission_key pid) read_perm ;
 116     Helm_registry.set_bool (write_permission_key pid) write_perm ;
 117     Helm_registry.set_bool (admin_permission_key pid) admin_perm ;
 118     Helm_registry.set_opt Helm_registry.set_string (password_key pid) password ;
 119     pid
 120
 121 let remove pid ?password () =
 122   check_permission pid password `Admin ;
 123   List.iter (fun (key, _) -> Helm_registry.unset key) (Helm_registry.to_list ~prefix:(profile_key pid) ())
 124
 125 let get_params pid ?password () =
 126    check_permission pid password `Read ;
 127    to_list_rel ~prefix:(params_key pid) ()
 128
 129 let set_param pid ?password ~key ~value () =
 130   check_permission pid password `Write ;
 131   match value with
 132       Some value' -> Helm_registry.set (param_key pid key) value'
 133     | None -> Helm_registry.unset (param_key pid key)
 134
 135 let get_param pid ?password ~key () =
 136   check_permission pid password `Read ;
 137   Helm_registry.get (param_key pid key)
 138
 139 let set_password pid ?old_password new_password =
 140   check_permission pid old_password `Admin ;
 141   Helm_registry.set_opt Helm_registry.set (password_key pid) new_password
 142
 143 let set_permission pid ?password for_what value =
 144   check_permission pid password `Admin ;
 145   Helm_registry.set_bool (permission_key for_what pid) value
 146
 147 let get_permission pid ?password for_what =
 148   check_permission pid password `Admin ;
 149   Helm_registry.get_bool (permission_key for_what pid)
 150