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
  98       when Some pwd = Helm_registry.get_opt Helm_registry.string (password_key pid) -> ()
  99     | _ -> raise (Access_denied (string_of_permission for_what, pid))
 100
 101 let create ?id ?clone ?clone_password ?(read_perm=true) ?(write_perm=true) ?(admin_perm=true) ?password () =
 102   let pid =
 103     match id with
 104         None -> create_fresh_id ()
 105       | Some pid when Helm_registry.has (read_permission_key pid) -> raise (Profile_exists pid)
 106       | Some pid -> pid
 107   in
 108   let params =
 109     match clone with
 110         None -> []
 111       | Some pid ->
 112           check_permission pid clone_password `Read ;
 113           to_list_rel ~prefix:(params_key pid) ()
 114   in
 115     List.iter (fun (key, value) -> Helm_registry.set_string (params_key pid ^ "." ^ key) value) params ;
 116     Helm_registry.set_bool (read_permission_key pid) read_perm ;
 117     Helm_registry.set_bool (write_permission_key pid) write_perm ;
 118     Helm_registry.set_bool (admin_permission_key pid) admin_perm ;
 119     Helm_registry.set_opt Helm_registry.of_string (password_key pid) password ;
 120     pid
 121
 122 let remove pid ?password () =
 123   check_permission pid password `Admin ;
 124   List.iter (fun (key, _) -> Helm_registry.unset key) (Helm_registry.to_list ~prefix:(profile_key pid) ())
 125
 126 let get_params pid ?password () =
 127    check_permission pid password `Read ;
 128    to_list_rel ~prefix:(params_key pid) ()
 129
 130 let set_param pid ?password ~key ~value () =
 131   check_permission pid password `Write ;
 132   match value with
 133       Some value' -> Helm_registry.set (param_key pid key) value'
 134     | None -> Helm_registry.unset (param_key pid key)
 135
 136 let get_param pid ?password ~key () =
 137   check_permission pid password `Read ;
 138   Helm_registry.get (param_key pid key)
 139
 140 let set_password pid ?old_password new_password =
 141   check_permission pid old_password `Admin ;
 142   Helm_registry.set_opt Helm_registry.of_string (password_key pid) new_password
 143
 144 let set_permission pid ?password for_what value =
 145   check_permission pid password `Admin ;
 146   Helm_registry.set_bool (permission_key for_what pid) value
 147
 148 let get_permission pid ?password for_what =
 149   check_permission pid password `Admin ;
 150   Helm_registry.get_bool (permission_key for_what pid)
 151