+++ /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