X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo.ml;h=1a5b44f620264f3c862bc09f3759b25c68dd311c;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=d680f9e2825d6ff6f80ff10efb90188a2e2c53a6;hpb=cb5860a98029772bfe3af081239fa2eb13075a32;p=helm.git diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml index d680f9e28..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" ;; @@ -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,21 +384,151 @@ 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 ("") 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 + ("") 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 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 *) @@ -371,7 +545,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 +558,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 +677,121 @@ 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 + | 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 *) + close_out res_pipe) | 0 -> (* (5) child: serve http requests *) Unix.close cmd_pipe_exit; Unix.close res_pipe_entrance;