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