X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo.ml;h=1a5b44f620264f3c862bc09f3759b25c68dd311c;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=2e454651906de8b5fcc208d8fb2cf6ef506ed986;hpb=2aea6f286c52d30eca4108ef357c97bbbcb3e3cf;p=helm.git diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml index 2e4546519..1a5b44f62 100644 --- a/helm/uwobo/uwobo.ml +++ b/helm/uwobo/uwobo.ml @@ -142,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 @@ -196,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 *) @@ -230,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 @@ -274,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")) @@ -364,7 +388,8 @@ let callback let profile_list = Uwobo_profiles.list () in respond_html ("") 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") @@ -372,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" -> @@ -391,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" -> @@ -416,8 +442,16 @@ let callback let res = Uwobo_profiles.get_params pid ?password () in respond_html ("") 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 @@ -483,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 *) @@ -633,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 @@ -647,15 +690,21 @@ 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 @@ -672,6 +721,20 @@ let main () = 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 = @@ -721,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 *)