--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+exception Impossible
+
+let (profile_db : (string, Profile.t) Hashtbl.t) =
+ try
+ let ch = open_in Profile_manager_env.profile_db_path in
+ input_value ch
+ with
+ _ -> Hashtbl.create 211
+
+let get_param_opt (req : Http_types.request) p =
+ try
+ match req#param p with
+ "" -> None
+ | s -> Some s
+ with
+ Http_types.Param_not_found _ -> None
+
+let new_key () =
+ let hex_of_nibble n =
+ if n >= 0 && n < 10 then
+ string_of_int n
+ else if n >= 10 && n < 16 then
+ String.make 1 (Char.chr (n - 10 + (Char.code 'A')))
+ else
+ raise Impossible
+ in
+ let rec aux s =
+ function
+ 0 -> s
+ | n -> aux ((hex_of_nibble (Random.int 16)) ^ s) (n - 1)
+ in
+ aux "" 4
+
+let new_unique_key =
+ let rec aux () =
+ let key = new_key () in
+ if Hashtbl.mem profile_db key then
+ aux ()
+ else
+ key
+ in
+ aux
+
+let list_profiles () =
+ let pl = ref [] in
+ Hashtbl.iter
+ (fun _ profile -> pl := (Profile.serialize profile false) :: !pl)
+ profile_db ;
+ "<profiles>" ^ (List.fold_left (^) "" !pl) ^ "</profiles>"
+
+let get_profile id pwd =
+ let profile = Hashtbl.find profile_db id in
+ Profile.get profile pwd
+
+let new_profile id pwd =
+ match id with
+ Some id' when Hashtbl.mem profile_db id' -> get_profile id' pwd
+ | Some id' ->
+ let profile = Profile.create id' pwd in
+ Hashtbl.add profile_db profile.Profile.id profile ;
+ Profile.serialize profile true
+ | None ->
+ let profile = Profile.create (new_unique_key ()) None in
+ Hashtbl.add profile_db profile.Profile.id profile ;
+ Profile.serialize profile true
+
+let set_profile id field value pwd =
+ let profile = Hashtbl.find profile_db id in
+ Profile.set profile field value pwd
+
+let del_profile id pwd =
+ let profile = Hashtbl.find profile_db id in
+ let res = Profile.del profile pwd in
+ Hashtbl.remove profile_db id ;
+ res
+
+let set_password id new_pwd pwd =
+ let profile = Hashtbl.find profile_db id in
+ Profile.set_password profile new_pwd pwd
+
+let set_access id read_access write_access profile_access pwd =
+ let profile = Hashtbl.find profile_db id in
+ Profile.set_access profile read_access write_access profile_access pwd
+
+let callback (req : Http_types.request) outchan =
+ let res =
+ try
+ prerr_endline ("Connection from " ^ req#clientAddr) ;
+ prerr_endline ("Received request: " ^ req#path) ;
+ begin
+ match req#path with
+ "/list" -> list_profiles ()
+ | "/get" ->
+ let id = req#param "id"
+ and pwd = get_param_opt req "password" in
+ get_profile id pwd
+ | "/set" ->
+ let id = req#param "id"
+ and field = req#param "field"
+ and value = get_param_opt req "value"
+ and pwd = get_param_opt req "password" in
+ set_profile id field value pwd
+ | "/del" ->
+ let id = req#param "id"
+ and pwd = get_param_opt req "password" in
+ del_profile id pwd
+ | "/new" ->
+ let id = get_param_opt req "id"
+ and pwd = get_param_opt req "password" in
+ new_profile id pwd
+ | "/password" ->
+ let id = req#param "id"
+ and old_pwd = get_param_opt req "old_password"
+ and new_pwd = get_param_opt req "new_password" in
+ set_password id new_pwd old_pwd
+ | "/access" ->
+ let id = req#param "id"
+ and pwd = get_param_opt req "password"
+ and read_access = get_param_opt req "read"
+ and write_access = get_param_opt req "write"
+ and profile_access = get_param_opt req "profile" in
+ set_access id read_access write_access profile_access pwd
+ | s -> Response.error ("unrecognized command: " ^ s)
+ end
+ with
+ Not_found -> Response.error "unknown profile"
+ | Profile.Permission_denied -> Response.error "permission denied"
+ | e -> Response.error ("uncaught exception: " ^ (Printexc.to_string e))
+ in
+ Http_daemon.respond
+ ~body:res ~headers:["Content-Type", "text/xml"] outchan
+
+ (* daemon initialization *)
+
+let save_db () =
+ let ch = open_out Profile_manager_env.profile_db_path in
+ output_value ch profile_db ;
+ close_out ch
+
+let main () =
+ at_exit save_db ;
+ Sys.catch_break true ;
+ try
+ Http_daemon.start' ~timeout:(Some 600) ~port:58099 ~mode:`Thread callback
+ with
+ Sys.Break -> ()
+in
+main ()
+
projects / helm.git / blobdiff