]> matita.cs.unibo.it Git - helm.git/blob - helm/uwobo/uwobo_profiles.ml
implemented copy/cut/paste/delete/pastePattern
[helm.git] / 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