]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/profile-manager/profile_manager.ml
ported to new syntactic requirement about terms being surrounded by parens
[helm.git] / helm / DEVEL / profile-manager / profile_manager.ml
1 (*
2  * Copyright (C) 2003:
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 exception Impossible
30
31 let (profile_db : (string, Profile.t) Hashtbl.t) =
32   try
33     let ch = open_in Profile_manager_env.profile_db_path in
34     input_value ch
35   with
36     _ -> Hashtbl.create 211
37
38 let get_param_opt (req : Http_types.request) p =
39   try
40     match req#param p with
41       "" -> None
42     | s -> Some s
43   with
44     Http_types.Param_not_found _ -> None
45
46 let new_key () =
47   let hex_of_nibble n =
48     if n >= 0 && n < 10 then
49       string_of_int n
50     else if n >= 10 && n < 16 then
51       String.make 1 (Char.chr (n - 10 + (Char.code 'A')))
52     else
53       raise Impossible
54   in
55   let rec aux s =
56     function
57         0 -> s
58       | n -> aux ((hex_of_nibble (Random.int 16)) ^ s) (n - 1)
59   in
60   aux "" 4
61
62 let new_unique_key =
63   let rec aux () =
64     let key = new_key () in
65     if Hashtbl.mem profile_db key then
66       aux ()
67     else
68       key
69   in
70   aux
71
72 let list_profiles () =
73   let pl = ref [] in
74   Hashtbl.iter
75     (fun _ profile -> pl := (Profile.serialize profile false) :: !pl)
76     profile_db ;
77   "<profiles>" ^ (List.fold_left (^) "" !pl) ^ "</profiles>"
78
79 let get_profile id pwd =
80   let profile = Hashtbl.find profile_db id in
81   Profile.get profile pwd
82
83 let new_profile id pwd =
84   match id with
85     Some id' when Hashtbl.mem profile_db id' -> get_profile id' pwd
86   | Some id' -> 
87       let profile = Profile.create id' pwd in
88       Hashtbl.add profile_db profile.Profile.id profile ;
89       Profile.serialize profile true
90   | None ->
91       let profile = Profile.create (new_unique_key ()) None in
92       Hashtbl.add profile_db profile.Profile.id profile ;
93       Profile.serialize profile true
94
95 let set_profile id field value pwd =
96   let profile = Hashtbl.find profile_db id in
97   Profile.set profile field value pwd
98
99 let del_profile id pwd =
100   let profile = Hashtbl.find profile_db id in
101   let res = Profile.del profile pwd in
102   Hashtbl.remove profile_db id ;
103   res
104
105 let set_password id new_pwd pwd =
106   let profile = Hashtbl.find profile_db id in
107   Profile.set_password profile new_pwd pwd
108
109 let set_access id read_access write_access profile_access pwd =
110   let profile = Hashtbl.find profile_db id in
111   Profile.set_access profile read_access write_access profile_access pwd
112
113 let callback (req : Http_types.request) outchan =
114   let res = 
115     try
116       prerr_endline ("Connection from " ^ req#clientAddr) ;
117       prerr_endline ("Received request: " ^ req#path) ;
118       begin
119         match req#path with
120           "/list" -> list_profiles ()
121         | "/get" ->
122             let id = req#param "id"
123             and pwd = get_param_opt req "password" in
124             get_profile id pwd
125         | "/set" ->
126             let id = req#param "id"
127             and field = req#param "field"
128             and value = get_param_opt req "value"
129             and pwd = get_param_opt req "password" in
130             set_profile id field value pwd
131         | "/del" ->
132             let id = req#param "id"
133             and pwd = get_param_opt req "password" in
134             del_profile id pwd
135         | "/new" ->
136             let id = get_param_opt req "id"
137             and pwd = get_param_opt req "password" in
138             new_profile id pwd
139         | "/password" ->
140             let id = req#param "id"
141             and old_pwd = get_param_opt req "old_password"
142             and new_pwd = get_param_opt req "new_password" in
143             set_password id new_pwd old_pwd
144         | "/access" ->
145             let id = req#param "id"
146             and pwd = get_param_opt req "password"
147             and read_access = get_param_opt req "read"
148             and write_access = get_param_opt req "write"
149             and profile_access = get_param_opt req "profile" in
150             set_access id read_access write_access profile_access pwd
151         | s -> Response.error ("unrecognized command: " ^ s)
152       end
153     with
154       Not_found -> Response.error "unknown profile"
155     | Profile.Permission_denied -> Response.error "permission denied"
156     | e -> Response.error ("uncaught exception: " ^ (Printexc.to_string e))
157   in
158   Http_daemon.respond
159     ~body:res ~headers:["Content-Type", "text/xml"] outchan
160
161     (* daemon initialization *)
162
163 let save_db () =
164   let ch = open_out Profile_manager_env.profile_db_path in
165   output_value ch profile_db ;
166   close_out ch
167
168 let main () =
169   at_exit save_db ;
170   Sys.catch_break true ;
171   try
172     Http_daemon.start' ~timeout:(Some 600) ~port:58099 ~mode:`Thread callback
173   with
174     Sys.Break -> ()
175 in
176 main ()
177