X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=inline;f=helm%2Fuwobo%2Fuwobo.ml;h=1a5b44f620264f3c862bc09f3759b25c68dd311c;hb=b17f04ca2d984e6a26e4dad9d35b881f64566951;hp=b51169c9ce464cfdcd8afc5dc69fbac9d3f6ff72;hpb=06e36b435676498b570b4e3591a52be726a42fe4;p=helm.git
diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml
index b51169c9c..1a5b44f62 100644
--- a/helm/uwobo/uwobo.ml
+++ b/helm/uwobo/uwobo.ml
@@ -35,13 +35,18 @@ let debug_level = `Notice ;;
let debug_print s = if debug then prerr_endline s ;;
Http_common.debug := false ;;
+let configuration_file = "/projects/helm/etc/uwobo.conf.xml";;
(* First of all we load the configuration *)
let _ =
- let configuration_file = "/projects/helm/etc/uwobo.conf.xml" in
Helm_registry.load_from configuration_file
;;
+let save_configuration () =
+ if not (Helm_registry.has "uwobo.cloned") then
+ Helm_registry.save_to configuration_file
+;;
+
(* other settings *)
let daemon_name = "UWOBO OCaml" ;;
let default_media_type = "text/html" ;;
@@ -137,7 +142,30 @@ let parse_apply_params =
((fun _ -> []), []) (* no parameters, no properties *)
;;
- (** Parse libxslt's message modes for error and debugging messages. Default is
+let serialize_param_list =
+ let is_global_param = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" in
+ let is_local_param = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" in
+ function params ->
+ let param_value_list =
+ List.filter
+ (fun (param, _) -> (is_global_param param) || (is_local_param param))
+ params
+ in
+ (String.concat
+ ","
+ (List.map
+ (fun (param, value) -> (Pcre.replace ~pat:"^param\\." param) ^ "=" ^ value)
+ param_value_list))
+
+let deserialize_param_list =
+ List.map
+ (fun pv ->
+ match Pcre.split ~pat:"=" pv with
+ [key] -> (key, None)
+ | [key; value] -> (key, Some value)
+ | _ -> assert false)
+
+(** Parse libxslt's message modes for error and debugging messages. Default is
to ignore mesages of both kind *)
let parse_libxslt_msgs_mode (req: Http_types.request) =
((try
@@ -191,10 +219,11 @@ let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE, kill_cmd_RE,
createprofile_cmd_RE, removeprofile_cmd_RE, setprofileparam_cmd_RE,
- setpassword_cmd_RE, setpermission_cmd_RE) =
+ setparams_cmd_RE, setpassword_cmd_RE, setpermission_cmd_RE) =
(Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ",
Pcre.regexp "^kill", Pcre.regexp "^createprofile ", Pcre.regexp "^removeprofile ",
- Pcre.regexp "^setprofileparam ", Pcre.regexp "^setpassword ", Pcre.regexp "^setpermission ")
+ Pcre.regexp "^setprofileparam ",
+ Pcre.regexp "^setparams ", Pcre.regexp "^setpassword ", Pcre.regexp "^setpermission ")
;;
(** raised by child processes when HTTP daemon process have to be restarted *)
@@ -225,7 +254,7 @@ let start_new_session cmd_pipe res_pipe outchan port logfile =
(* Let's check that the port is free *)
(try
ignore
- (Http_client.http_get
+ (Http_user_agent.get
("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ;
raise (Failure "Port already in use")
with
@@ -254,7 +283,8 @@ let start_new_session cmd_pipe res_pipe outchan port logfile =
let environment =
(* Here I am loosing the current value of port_env_var; *)
(* this should not matter *)
- Unix.putenv "UWOBO__PORT" (string_of_int port) ;
+ Unix.putenv "uwobo__port" (string_of_int port) ;
+ Unix.putenv "uwobo__cloned" "1" ;
Unix.environment ()
in
(* 4. We exec a new copy of uwobo *)
@@ -268,7 +298,7 @@ let start_new_session cmd_pipe res_pipe outchan port logfile =
(* It can raise Failure "Connection refused" *)
(try
ignore
- (Http_client.http_get
+ (Http_user_agent.get
("http://127.0.0.1:" ^ string_of_int port ^ "/help"))
with Unix.Unix_error (Unix.ECONNREFUSED, _, _) ->
raise (Failure "Connection refused"))
@@ -358,7 +388,8 @@ let callback
let profile_list = Uwobo_profiles.list () in
respond_html ("
" ^ String.concat "" (List.map (fun s -> "- " ^ s ^ "
") profile_list) ^ "
") outchan
| "/createprofile" ->
- let cmd = sprintf "createprofile %s,%s,%s,%s,%s,%s,%s"
+ let serialized_param_value_list = serialize_param_list req#params in
+ let cmd = sprintf "createprofile %s,%s,%s,%s,%s,%s,%s,%s"
(string_of_param_option req "id")
(string_of_param_option req "orig")
(string_of_param_option req "origpassword")
@@ -366,6 +397,7 @@ let callback
(string_of_param_option req "writeperm")
(string_of_param_option req "adminperm")
(string_of_param_option req "password")
+ serialized_param_value_list
in
short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
| "/removeprofile" ->
@@ -374,7 +406,7 @@ let callback
(string_of_param_option req "password")
in
short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
- | "/setprofileparam" ->
+ | "/setparam" ->
let cmd = sprintf "setprofileparam %s,%s,%s,%s"
(string_of_param_option req "id")
(string_of_param_option req "password")
@@ -385,8 +417,8 @@ let callback
| "/setpassword" ->
let cmd = sprintf "setpassword %s,%s,%s"
(req#param "id")
- (string_of_param_option req "password")
(string_of_param_option req "oldpassword")
+ (string_of_param_option req "password")
in
short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
| "/setpermission" ->
@@ -410,8 +442,16 @@ let callback
let res = Uwobo_profiles.get_params pid ?password () in
respond_html
("" ^
- String.concat "" (List.map (fun k,v -> "- " ^ k ^ " = " ^ v ^ "
") res) ^
+ String.concat "" (List.map (fun (k,v) -> "- " ^ k ^ " = " ^ v ^ "
") res) ^
"
") outchan
+ | "/setparams" ->
+ let serialized_param_value_list = serialize_param_list req#params in
+ let cmd = sprintf "setparams %s,%s,%s"
+ (req#param "id")
+ (string_of_param_option req "password")
+ serialized_param_value_list
+ in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
| "/getparam" ->
let pid = req#param "id" in
let password = try Some (req#param "password") with _ -> None in
@@ -432,7 +472,7 @@ let callback
match forwhat with
Some forwhat ->
let value = Uwobo_profiles.get_permission pid ?password forwhat in
- respond_html ("" ^ (if value then "true" else "false") ^ "") outchan
+ respond_html ("" ^ (if value then "public" else "private") ^ "") outchan
| None -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan ;
end
| "/apply" ->
@@ -477,6 +517,18 @@ let callback
syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
let domImpl = Gdome.domImplementation () in
let input = domImpl#createDocumentFromURI ~uri:xmluri () in
+ if debug then begin
+ let tmp_xml, tmp_uri =
+ let dir =
+ Filename.dirname (Helm_registry.get "uwobo.log_basename")
+ in
+ dir ^ "/input.xml", dir ^ "/input.uri"
+ in
+ ignore (domImpl#saveDocumentToFile ~doc:input ~name:tmp_xml ());
+ let oc = open_out tmp_uri in
+ output_string oc xmluri;
+ close_out oc
+ end;
syslogger#log `Debug "Applying stylesheet chain ...";
(try
let (write_result, media_type, encoding) = (* out_channel -> unit *)
@@ -627,12 +679,9 @@ let main () =
raise Restart_HTTP_daemon
| line when Pcre.pmatch ~rex:createprofile_cmd_RE line -> (* /createprofile *)
stop_http_daemon ();
- let params =
- List.map string_option_of_string (Pcre.split ~pat:"," (Pcre.replace ~rex:createprofile_cmd_RE line))
- in
begin
- match params with
- [id; clone; clone_password; read_perm; write_perm; admin_perm; password] ->
+ match (Pcre.split ~pat:"," (Pcre.replace ~rex:createprofile_cmd_RE line)) with
+ id::clone::clone_password::read_perm::write_perm::admin_perm::password::pv_list ->
let bool_option_of_string_option =
function
Some "true" -> Some true
@@ -641,15 +690,22 @@ let main () =
in
let pid =
Uwobo_profiles.create
- ?id
- ?clone
- ?clone_password
- ?read_perm:(bool_option_of_string_option read_perm)
- ?write_perm:(bool_option_of_string_option write_perm)
- ?admin_perm:(bool_option_of_string_option admin_perm)
- ?password
+ ?id:(string_option_of_string id)
+ ?clone:(string_option_of_string clone)
+ ?clone_password:(string_option_of_string clone_password)
+ ?read_perm:(bool_option_of_string_option (string_option_of_string read_perm))
+ ?write_perm:(bool_option_of_string_option (string_option_of_string write_perm))
+ ?admin_perm:(bool_option_of_string_option (string_option_of_string admin_perm))
+ ?password:(string_option_of_string password)
()
in
+ let pv_list' = (deserialize_param_list pv_list) in
+ List.iter
+ (fun (key, value) ->
+ Uwobo_profiles.set_param
+ pid ?password:(string_option_of_string password) ~key ~value ())
+ pv_list' ;
+ save_configuration () ;
output_string res_pipe ("Profile " ^ pid ^ " created. Hi " ^ pid) ;
raise Restart_HTTP_daemon
| _ -> assert false
@@ -662,8 +718,23 @@ let main () =
| _ -> assert false
in
Uwobo_profiles.remove pid ?password () ;
+ save_configuration () ;
output_string res_pipe "Done" ;
raise Restart_HTTP_daemon
+ | line when Pcre.pmatch ~rex:setparams_cmd_RE line -> (* /setparams *)
+ stop_http_daemon () ;
+ let pid, password, pv_list =
+ match Pcre.split ~pat:"," (Pcre.replace ~rex:setparams_cmd_RE line) with
+ pid::password::pv_list ->
+ pid, (string_option_of_string password), (deserialize_param_list pv_list)
+ | _ -> assert false
+ in
+ List.iter
+ (fun (key, value) -> Uwobo_profiles.set_param pid ?password ~key ~value ())
+ pv_list ;
+ save_configuration () ;
+ output_string res_pipe "Done" ;
+ raise Restart_HTTP_daemon
| line when Pcre.pmatch ~rex:setprofileparam_cmd_RE line -> (* /setprofileparam *)
stop_http_daemon ();
let pid, password, key, value =
@@ -673,6 +744,7 @@ let main () =
| _ -> assert false
in
Uwobo_profiles.set_param pid ?password ~key ~value () ;
+ save_configuration () ;
output_string res_pipe "Done" ;
raise Restart_HTTP_daemon
| line when Pcre.pmatch ~rex:setpassword_cmd_RE line -> (* /setpassword *)
@@ -684,6 +756,7 @@ let main () =
| _ -> assert false
in
Uwobo_profiles.set_password pid ?old_password password ;
+ save_configuration () ;
output_string res_pipe "Done" ;
raise Restart_HTTP_daemon
| line when Pcre.pmatch ~rex:setpermission_cmd_RE line -> (* /setpermission *)
@@ -694,7 +767,7 @@ let main () =
| "write" -> `Write
| "admin" -> `Admin
| _ -> assert false
- and bool_of_string s = "true" = s
+ and bool_of_string s = "public" = s
in
let pid, password, forwhat, value =
match Pcre.split ~pat:"," (Pcre.replace ~rex:setpermission_cmd_RE line) with
@@ -703,6 +776,7 @@ let main () =
| _ -> assert false
in
Uwobo_profiles.set_permission pid ?password forwhat value ;
+ save_configuration () ;
output_string res_pipe "Done" ;
raise Restart_HTTP_daemon
| cmd -> (* invalid interprocess command received *)
@@ -710,9 +784,10 @@ let main () =
(sprintf "Ignoring invalid interprocess command: '%s'" cmd))
done
with
- Restart_HTTP_daemon ->
+ | Restart_HTTP_daemon ->
close_in cmd_pipe; (* these calls close also fds *)
close_out res_pipe
+ | Sys.Break as exn -> raise exn
| e -> (* Should we return a 404 error here? Maybe... (how?) *)
output_string res_pipe (Printexc.to_string e);
close_in cmd_pipe; (* these calls close also fds *)