((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
(* 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
(* 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"))
let profile_list = Uwobo_profiles.list () in
respond_html ("<html><body><ul>" ^ String.concat "" (List.map (fun s -> "<li>" ^ s ^ "</li>") profile_list) ^ "</ul></body></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")
(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" ->
| "/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" ->
let res = Uwobo_profiles.get_params pid ?password () in
respond_html
("<html><body><ul>" ^
- String.concat "" (List.map (fun k,v -> "<li><key>" ^ k ^ "</key> = <value>" ^ v ^ "</value></li>") res) ^
+ String.concat "" (List.map (fun (k,v) -> "<li><key>" ^ k ^ "</key> = <value>" ^ v ^ "</value></li>") res) ^
"</ul></body></html>") outchan
| "/setparams" ->
- let is_global_param = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" in
- let is_local_param = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" in
- let param_value_list =
- List.filter
- (fun (param, _) -> (is_global_param param) || (is_local_param param))
- req#params
- in
- let serialized_param_value_list =
- List.map
- (fun (param, value) -> (Pcre.replace ~pat:"^param\\." param) ^ "=" ^ value)
- param_value_list
- in
+ 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")
- (String.concat "," serialized_param_value_list)
+ serialized_param_value_list
in
short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
| "/getparam" ->
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 *)
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
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
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),
- (List.map
- (fun pv ->
- match Pcre.split ~pat:"=" pv with
- [key] -> (key, None)
- | [key; value] -> (key, Some value)
- | _ -> assert false)
- pv_list)
+ pid, (string_option_of_string password), (deserialize_param_list pv_list)
| _ -> assert false
in
List.iter
(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 *)
projects / helm.git / blobdiff