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" ;;
((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 (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 *)
(* 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
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 *)
(* 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" ->
(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")
| "/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>" ^ k ^ " = " ^ v ^ "</li>") res) ^
+ String.concat "" (List.map (fun (k,v) -> "<li><key>" ^ k ^ "</key> = <value>" ^ v ^ "</value></li>") res) ^
"</ul></body></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
match forwhat with
Some forwhat ->
let value = Uwobo_profiles.get_permission pid ?password forwhat in
- respond_html ("<html><body>" ^ (if value then "true" else "false") ^ "</body></html>") outchan
+ respond_html ("<html><body>" ^ (if value then "public" else "private") ^ "</body></html>") outchan
| None -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan ;
end
| "/apply" ->
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
| _ -> assert false
| _ -> 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 =
| _ -> 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 *)
| _ -> 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 *)
| "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
| _ -> 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 *)