X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo.ml;h=1a5b44f620264f3c862bc09f3759b25c68dd311c;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=a9755885d2463f65490c4f263c1d0ccc0f09c02d;hpb=c6eb317ba149b744e63a20b5f93ce64fec254cb4;p=helm.git diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml index a9755885d..1a5b44f62 100644 --- a/helm/uwobo/uwobo.ml +++ b/helm/uwobo/uwobo.ml @@ -35,13 +35,20 @@ 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 _ = + 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_log_base_file = "log/uwobo" ;; (* relative to execution dir *) -let log_extension = ".log" ;; -let default_port = 58080 ;; -let port_env_var = "UWOBO_PORT" ;; -let log_env_var = "UWOBO_LOG_FILE" ;; (* The extension _pid.log will be added *) let default_media_type = "text/html" ;; let default_encoding = "utf8" ;; @@ -59,24 +66,25 @@ let get_encoding props = Not_found -> default_encoding ;; -let port = +let string_of_param_option (req: Http_types.request) name = try - int_of_string (Sys.getenv port_env_var) + req#param name with - | Not_found -> default_port - | Failure "int_of_string" -> - prerr_endline "Warning: invalid port number" ; - exit (-1) -;; + 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 = - let basename = - try - Sys.getenv log_env_var - with - Not_found -> default_log_base_file - in - basename ^ "_" ^ string_of_int port ^ log_extension + let basename = Helm_registry.get "uwobo.log_basename" in + let extension = Helm_registry.get "uwobo.log_extension" in + basename ^ "_" ^ string_of_int port ^ extension ;; + let logfile = logfilename_of_port port;; let logfile_perm = 0o640 ;; @@ -134,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 @@ -174,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 @@ -186,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 *) @@ -216,55 +251,58 @@ let veillogger = new Uwobo_common.libXsltLogger ;; (* It can raise Failure "Connection refused" *) (* It can raise Failure "Port already in use" *) 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 port_env_var (string_of_int port) ; - Unix.environment () - in - (* Let's check that the port is free *) - (try - ignore - (Http_client.http_get - ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ; - raise (Failure "Port already in use") - with - Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> () - ) ; - match Unix.fork () with - 0 -> - Unix.handle_unix_error - (function () -> - (* 1. We close all the open pipes to avoid duplicating them *) - Unix.close (Unix.descr_of_out_channel cmd_pipe) ; - Unix.close (Unix.descr_of_in_channel res_pipe) ; - Unix.close (Unix.descr_of_out_channel outchan) ; - (* 2. We redirect stdout and stderr to the logfile *) - Unix.close Unix.stdout ; - assert - (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT] - 0o664 = Unix.stdout) ; - Unix.close Unix.stderr ; - assert - (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT] - 0o664 = Unix.stderr) ; - prerr_endline "***** Starting a new session" ; - (* 3. We exec a new copy of uwobo *) - Unix.execve Sys.executable_name [||] environment ; - (* It should never reach this point *) - assert false - ) () - | child when child > 0 -> - (* let's check if the new UWOBO started correctly *) - Unix.sleep 5 ; - (* It can raise Failure "Connection refused" *) - (try - ignore - (Http_client.http_get - ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) - with Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> - raise (Failure "Connection refused")) - | _ -> failwith "Can't fork :-(" + (* Let's check that the port is free *) + (try + ignore + (Http_user_agent.get + ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ; + raise (Failure "Port already in use") + with + Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> () + ) ; + match Unix.fork () with + 0 -> + Unix.handle_unix_error + (function () -> + (* 1. We close all the open pipes to avoid duplicating them *) + Unix.close (Unix.descr_of_out_channel cmd_pipe) ; + Unix.close (Unix.descr_of_in_channel res_pipe) ; + Unix.close (Unix.descr_of_out_channel outchan) ; + (* 2. We redirect stdout and stderr to the logfile *) + Unix.close Unix.stdout ; + assert + (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT] + 0o664 = Unix.stdout) ; + Unix.close Unix.stderr ; + assert + (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT] + 0o664 = Unix.stderr) ; + prerr_endline "***** Starting a new session" ; + + (* 3. We set up a new environment *) + 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__cloned" "1" ; + Unix.environment () + in + (* 4. We exec a new copy of uwobo *) + Unix.execve Sys.executable_name [||] environment ; + (* It should never reach this point *) + assert false + ) () + | child when child > 0 -> + (* let's check if the new UWOBO started correctly *) + Unix.sleep 5 ; + (* It can raise Failure "Connection refused" *) + (try + ignore + (Http_user_agent.get + ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) + with Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> + raise (Failure "Connection refused")) + | _ -> failwith "Can't fork :-(" ;; (* request handler action @@ -346,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 *) @@ -377,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 @@ -390,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 -> @@ -509,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;