X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=inline;f=helm%2Fuwobo%2Fuwobo.ml;h=d8341aeb6d924b3fd77cd979f75c492cd3cd1e33;hb=f44a2623c7790b8ad052e967c008869ab017d7e9;hp=d680f9e2825d6ff6f80ff10efb90188a2e2c53a6;hpb=cb5860a98029772bfe3af081239fa2eb13075a32;p=helm.git
diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml
index d680f9e28..d8341aeb6 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" ;;
@@ -61,6 +66,17 @@ let get_encoding props =
Not_found -> default_encoding
;;
+let string_of_param_option (req: Http_types.request) name =
+ try
+ req#param name
+ with
+ Http_types.Param_not_found _ -> "#"
+
+let string_option_of_string =
+ function
+ "#" -> None
+ | s -> Some s
+
let port = Helm_registry.get_int "uwobo.port";;
let logfilename_of_port port =
@@ -126,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
@@ -166,7 +205,7 @@ let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
in
(match read_fds with
| [fd] when fd = res_pipe_fd -> (* send answer to http client *)
- Http_daemon.send_basic_headers ~code:200 outchan;
+ Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
Http_daemon.send_header "Content-Type" "text/html" outchan;
Http_daemon.send_CRLF outchan;
(try
@@ -178,9 +217,13 @@ let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
return_error "Timeout!" outchan)
;;
-let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE, kill_cmd_RE) =
+let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE, kill_cmd_RE,
+ createprofile_cmd_RE, removeprofile_cmd_RE, setprofileparam_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 "^kill", Pcre.regexp "^createprofile ", Pcre.regexp "^removeprofile ",
+ Pcre.regexp "^setprofileparam ",
+ Pcre.regexp "^setparams ", Pcre.regexp "^setpassword ", Pcre.regexp "^setpermission ")
;;
(** raised by child processes when HTTP daemon process have to be restarted *)
@@ -211,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
@@ -240,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 *)
@@ -254,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"))
@@ -340,15 +384,133 @@ let callback
logger#log "Stylesheets list:";
List.iter (fun s -> logger#log s) l);
respond_html logger#asHtml outchan)
+ | "/listprofiles" ->
+ let profile_list = Uwobo_profiles.list () in
+ respond_html ("
" ^ String.concat "" (List.map (fun s -> "- " ^ s ^ "
") profile_list) ^ "
") outchan
+ | "/createprofile" ->
+ 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 "readperm")
+ (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" ->
+ let cmd = sprintf "removeprofile %s,%s"
+ (req#param "id")
+ (string_of_param_option req "password")
+ in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+ | "/setparam" ->
+ let cmd = sprintf "setprofileparam %s,%s,%s,%s"
+ (string_of_param_option req "id")
+ (string_of_param_option req "password")
+ (req#param "key")
+ (string_of_param_option req "value")
+ in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+ | "/setpassword" ->
+ let cmd = sprintf "setpassword %s,%s,%s"
+ (req#param "id")
+ (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" ->
+ begin
+ match req#param "for" with
+ "read"
+ | "write"
+ | "admin" as forwhat ->
+ let cmd = sprintf "setpermission %s,%s,%s,%s"
+ (req#param "id")
+ (string_of_param_option req "password")
+ forwhat
+ (req#param "value")
+ in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+ | _ -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan
+ end
+ | "/getparams" ->
+ let pid = req#param "id" in
+ let password = try Some (req#param "password") with _ -> None in
+ let res = Uwobo_profiles.get_params pid ?password () in
+ respond_html
+ ("" ^
+ 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
+ let key = req#param "key" in
+ let value = Uwobo_profiles.get_param pid ?password ~key () in
+ respond_html ("" ^ value ^ "") outchan
+ | "/getpermission" ->
+ let pid = req#param "id" in
+ let password = try Some (req#param "password") with _ -> None in
+ let forwhat =
+ match req#param "for" with
+ "read" -> Some `Read
+ | "write" -> Some `Write
+ | "admin" -> Some `Admin
+ | _ -> None
+ in
+ begin
+ match forwhat with
+ Some forwhat ->
+ let value = Uwobo_profiles.get_permission pid ?password forwhat in
+ respond_html ("" ^ (if value then "public" else "private") ^ "") outchan
+ | None -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan ;
+ end
| "/apply" ->
let logger = new Uwobo_logger.processingLogger () in
veillogger#clearMsgs;
+ let profile = try Some (req#param "profile") with _ -> None in
+ let password = try Some (req#param "password") with _ -> None in
let xmluri = req#param "xmluri" in
let keys = Pcre.split ~pat:"," (req#param "keys") in
(* notation: "local" parameters are those defined on a per-stylesheet
pasis (i.e. param.key.param=value), "global" parameters are those
defined for all stylesheets (i.e. param.param=value) *)
- let (params, props) = parse_apply_params req#params in
+ let (user_params, props) = parse_apply_params req#params in
+ let profile_params =
+ match profile with
+ None -> []
+ | Some profile -> Uwobo_profiles.get_params profile ?password () in
+ let params =
+ (* user provided parameters override the profile parameters *)
+ let is_global_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){1}$" ("." ^ x) in
+ let is_local_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){2}$" ("." ^ x) in
+ let add key value params =
+ if List.mem_assoc key params then params else params @ [key,value]
+ in
+ List.fold_left
+ (fun old_params (name, value) ->
+ match name with
+ | name when is_global_param name ->
+ (fun x -> add name value (old_params x))
+ | name when is_local_param name ->
+ let pieces = Pcre.extract ~pat:"^([^.]+)\\.(.*)" name in
+ let (key, name) = (pieces.(1), pieces.(2)) in
+ (function
+ | x when x = key -> add name value (old_params x)
+ | x -> old_params x)
+ | _ -> assert false)
+ user_params profile_params
+ in
let (libxslt_errormode, libxslt_debugmode) =
parse_libxslt_msgs_mode req
in
@@ -371,7 +533,7 @@ let callback
syslogger#log `Debug
(sprintf "sending output to client (Content-Type: %s)...."
content_type);
- Http_daemon.send_basic_headers ~code:200 outchan;
+ Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
Http_daemon.send_header "Content-Type" content_type outchan;
Http_daemon.send_CRLF outchan;
write_result outchan
@@ -384,7 +546,7 @@ let callback
outchan)
| "/help" -> respond_html usage_string outchan
| invalid_request ->
- Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
+ Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan);
syslogger#log `Debug (sprintf "%s done!" req#path);
with
| Http_types.Param_not_found attr_name ->
@@ -503,13 +665,120 @@ let main () =
"reloading";
output_string res_pipe (logger#asHtml);
raise Restart_HTTP_daemon
+ | line when Pcre.pmatch ~rex:createprofile_cmd_RE line -> (* /createprofile *)
+ stop_http_daemon ();
+ begin
+ 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
+ | Some _ -> Some false
+ | None -> None
+ in
+ let pid =
+ Uwobo_profiles.create
+ ?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
+ end
+ | line when Pcre.pmatch ~rex:removeprofile_cmd_RE line -> (* /removeprofile *)
+ stop_http_daemon ();
+ let pid, password =
+ match Pcre.split ~pat:"," (Pcre.replace ~rex:removeprofile_cmd_RE line) with
+ [pid; password] -> pid, (string_option_of_string password)
+ | _ -> 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 =
+ match Pcre.split ~pat:"," (Pcre.replace ~rex:setprofileparam_cmd_RE line) with
+ [pid; password; key; value] ->
+ pid, (string_option_of_string password), key, (string_option_of_string 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 *)
+ stop_http_daemon ();
+ let pid, old_password, password =
+ match Pcre.split ~pat:"," (Pcre.replace ~rex:setpassword_cmd_RE line) with
+ [pid; old_password; password] ->
+ pid, (string_option_of_string old_password), (string_option_of_string password)
+ | _ -> 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 *)
+ stop_http_daemon ();
+ let permission_of_string =
+ function
+ "read" -> `Read
+ | "write" -> `Write
+ | "admin" -> `Admin
+ | _ -> assert false
+ 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
+ [pid; password; forwhat; value] ->
+ pid, (string_option_of_string password), (permission_of_string forwhat), (bool_of_string value)
+ | _ -> 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 *)
syslogger#log `Warning
(sprintf "Ignoring invalid interprocess command: '%s'" cmd))
done
- with Restart_HTTP_daemon ->
- close_in cmd_pipe; (* these calls close also fds *)
- close_out res_pipe;)
+ with
+ Restart_HTTP_daemon ->
+ close_in cmd_pipe; (* these calls close also fds *)
+ close_out res_pipe
+ | 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 *)
+ close_out res_pipe)
| 0 -> (* (5) child: serve http requests *)
Unix.close cmd_pipe_exit;
Unix.close res_pipe_entrance;