X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo.ml;h=1a5b44f620264f3c862bc09f3759b25c68dd311c;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=a88f9484fc4b4bf1647a5b03b086efbe6d1ade03;hpb=d6cb4446b6c5653dcdfb555959e388ef1c4c6411;p=helm.git diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml index a88f9484f..1a5b44f62 100644 --- a/helm/uwobo/uwobo.ml +++ b/helm/uwobo/uwobo.ml @@ -35,34 +35,67 @@ 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_file = "uwobo.log" ;; (* relative to execution dir *) -let default_port = 58080 ;; -let port_env_var = "UWOBO_PORT" ;; let default_media_type = "text/html" ;; let default_encoding = "utf8" ;; -let logfile = - Some (try Sys.getenv "UWOBO_LOG_FILE" with Not_found -> default_log_file) + +let get_media_type props = + try + List.assoc "media-type" props + with + Not_found -> default_media_type ;; -let logfile_perm = 0o640 ;; -let port = + +let get_encoding props = + try + List.assoc "encoding" props + with + Not_found -> default_encoding +;; + +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, reverting to default"; - default_port + 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 = 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 ;; + let respond_html body outchan = Http_daemon.respond ~body ~headers:["Content-Type", "text/html"] outchan ;; (** perform an 'action' that can be applied to a list of keys or, if no keys was given, to all keys *) -let act_on_keys keys_param styles logger per_key_action all_keys_action logmsg +let act_on_keys + keys_param styles logger per_key_action all_keys_action all_keys logmsg = let keys = try @@ -71,13 +104,16 @@ let act_on_keys keys_param styles logger per_key_action all_keys_action logmsg in match keys with | [] -> (* no key provided, act on all stylesheets *) - logger#log (sprintf "%s all stylesheets ..." logmsg); - (try all_keys_action () with e -> logger#log (Printexc.to_string e)) + logger#log (sprintf "%s all stylesheets (keys = %s) ..." + logmsg (String.concat ", " all_keys)); + (try all_keys_action () with e -> logger#log (Printexc.to_string e)); + logger#log (sprintf "Done! (all stylesheets)") | keys -> List.iter (fun key -> (* act on a single stylesheet *) logger#log (sprintf "%s stylesheet %s" logmsg key); - (try per_key_action key with e -> logger#log (Printexc.to_string e))) + (try per_key_action key with e -> logger#log (Printexc.to_string e)); + logger#log (sprintf "Done! (stylesheet %s)" key)) keys ;; @@ -106,6 +142,56 @@ let parse_apply_params = ((fun _ -> []), []) (* no parameters, no properties *) ;; +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 + (match req#param "errormode" with + | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore + | s when String.lowercase s = "comment" -> LibXsltMsgComment + | s when String.lowercase s = "embed" -> LibXsltMsgEmbed + | err -> + raise (Uwobo_failure + (sprintf + "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'" + err "errormode" "ignore" "comment"))) + with Http_types.Param_not_found _ -> LibXsltMsgIgnore), + (try + (match req#param "debugmode" with + | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore + | s when String.lowercase s = "comment" -> LibXsltMsgComment + | s when String.lowercase s = "embed" -> LibXsltMsgEmbed + | err -> + raise (Uwobo_failure + (sprintf + "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'" + err "debugmode" "ignore" "comment"))) + with Http_types.Param_not_found _ -> LibXsltMsgIgnore)) +;; + (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer on ~res_pipe (with a timeout of 60 seconds) and send over outchan data received from ~res_pipe *) @@ -119,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 @@ -131,20 +217,92 @@ 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) = - (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ") +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 "^createprofile ", Pcre.regexp "^removeprofile ", + Pcre.regexp "^setprofileparam ", + Pcre.regexp "^setparams ", Pcre.regexp "^setpassword ", Pcre.regexp "^setpermission ") ;; -exception Restart_HTTP_daemon;; + (** raised by child processes when HTTP daemon process have to be restarted *) +exception Restart_HTTP_daemon ;; (** log a list of libxslt's messages using a processing logger *) -let log_libxslt_msgs logger = +let log_libxslt_msgs logger libxslt_logger = List.iter (function - | Uwobo_styles.LibXsltErrorMsg msg -> - logger#logBold ("LibXSLT ERROR: " ^ msg) - | Uwobo_styles.LibXsltDebugMsg msg -> - logger#logEmph ("LibXSLT DEBUG " ^ msg)) + | (LibXsltErrorMsg _) as msg -> logger#logBold (string_of_xslt_msg msg) + | (LibXsltDebugMsg _) as msg -> logger#logEmph (string_of_xslt_msg msg)) + libxslt_logger#msgs +;; + + (* LibXSLT logger *) +let veillogger = new Uwobo_common.libXsltLogger ;; + + (* start_new_session cmd_pipe_exit res_pipe_entrance outchan port logfile + @param cmd_pipe Pipe to be closed before forking + @param res_pipe Pipe to be closed before forking + @param outchan To be closed before forking + @param port The port to be used + @param logfile The logfile to redirect the stdout and sterr to + *) + (* 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'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 @@ -170,6 +328,48 @@ let callback let cmd = sprintf "add %s" (String.concat ";" bindings) in short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan end) + | "/kill" -> + let logger = new Uwobo_logger.processingLogger () in + logger#log "Exiting" ; + respond_html logger#asHtml outchan ; + let cmd = "kill" in + short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan + | "/newsession" -> + let logger = new Uwobo_logger.processingLogger () in + let port = int_of_string (req#param "port") in + let logfile = logfilename_of_port port in + (try + start_new_session cmd_pipe res_pipe outchan port logfile ; + logger#log (sprintf "New session started: port = %d" port) ; + respond_html logger#asHtml outchan + with + Failure "int_of_string" -> + logger#log (sprintf "Invalid port number") ; + respond_html logger#asHtml outchan + | Failure "Port already in use" -> + Uwobo_common.return_error "port already in use" outchan + | Failure "Connection refused" -> + let log = ref [] in + (try + let ch = open_in logfile in + while true do log := (input_line ch ^ "\n") :: !log ; done + with + Sys_error _ + | End_of_file -> () + ) ; + let rec get_last_lines acc = + function + (n,he::tl) when n > 0 -> + get_last_lines (he ^ "
" ^ acc) (n-1,tl) + | _ -> acc + in + (* we just show the last 10 lines of the log file *) + let msg = + (if List.length !log > 0 then "
...
" else "
") ^ + get_last_lines "" (10,!log) + in + Uwobo_common.return_error "daemon not initialized" + ~body:msg outchan) | "/remove" -> let cmd = sprintf "remove %s" (req#param "keys") in short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan @@ -177,50 +377,188 @@ let callback let cmd = sprintf "reload %s" (req#param "keys") in short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan | "/list" -> - (let log = new Uwobo_logger.processingLogger () in + (let logger = new Uwobo_logger.processingLogger () in (match styles#list with - | [] -> log#log "No stylesheets loaded (yet)!" + | [] -> logger#log "No stylesheets loaded (yet)!" | l -> - log#log "Stylesheets list:"; - List.iter (fun s -> log#log s) l); - respond_html log#asHtml outchan) + 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 *) - let res = Uwobo_engine.apply - ~logger:syslogger ~styles ~keys ~input ~params ~props in - res + Uwobo_engine.apply + ~logger:syslogger ~styles ~keys ~params ~props ~veillogger + ~errormode:libxslt_errormode ~debugmode:libxslt_debugmode + input in let content_type = (* value of Content-Type HTTP response header *) sprintf "%s; charset=%s" - (match media_type with None -> default_media_type | Some t -> t) - (match encoding with None -> default_encoding | Some e -> e) + (match media_type with None -> get_media_type props | Some t -> t) + (match encoding with None -> get_encoding props | Some e -> e) in 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 with Uwobo_failure errmsg -> return_error - (sprintf "Stylesheet chain application failed: %s" errmsg) + ("Stylesheet chain application failed: " ^ errmsg) + ~body: ("

LibXSLT's messages:

" ^ + String.concat "
\n" + (List.map string_of_xslt_msg veillogger#msgs)) 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 -> @@ -233,13 +571,8 @@ let callback let main () = (* (1) system logger *) let logger_outchan = - match logfile with - | None -> - debug_print "Logging to standard error"; - stderr - | Some f -> - debug_print (sprintf "Logging to file %s" f); - open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm f + debug_print (sprintf "Logging to file %s" logfile); + open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm logfile in let syslogger = new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan () @@ -295,56 +628,170 @@ let main () = output_string res_pipe "UWOBOmaster: Hello, world!\n"; flush res_pipe; raise Restart_HTTP_daemon + | line when Pcre.pmatch ~rex:kill_cmd_RE line -> (* /kill *) + exit 0 | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *) let bindings = Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line) in stop_http_daemon (); - let log = new Uwobo_logger.processingLogger () in + let logger = new Uwobo_logger.processingLogger () in List.iter (fun binding -> (* add a binding *) let pieces = Pcre.split ~pat:"," binding in match pieces with | [key; style] -> - log#log (sprintf "adding binding <%s,%s>" key style); + logger#log (sprintf "adding binding <%s,%s>" key style); + veillogger#clearMsgs; (try - log_libxslt_msgs log (styles#add key style) + veillogger#clearMsgs; + styles#add key style; + log_libxslt_msgs logger veillogger; with e -> - log#log (Printexc.to_string e)) - | _ -> log#log (sprintf "invalid binding %s" binding)) + logger#log (Printexc.to_string e)) + | _ -> logger#log (sprintf "invalid binding %s" binding)) bindings; - output_string res_pipe log#asHtml; + output_string res_pipe logger#asHtml; flush res_pipe; raise Restart_HTTP_daemon | line when Pcre.pmatch ~rex:remove_cmd_RE line -> (* /remove *) stop_http_daemon (); let arg = Pcre.replace ~rex:remove_cmd_RE line in let logger = new Uwobo_logger.processingLogger () in + veillogger#clearMsgs; act_on_keys arg styles logger - (fun key -> log_libxslt_msgs logger (styles#remove key)) - (fun () -> log_libxslt_msgs logger styles#removeAll) + styles#remove (fun () -> styles#removeAll) styles#keys "removing"; + log_libxslt_msgs logger veillogger; output_string res_pipe (logger#asHtml); raise Restart_HTTP_daemon | line when Pcre.pmatch ~rex:reload_cmd_RE line -> (* /reload *) stop_http_daemon (); let arg = Pcre.replace ~rex:reload_cmd_RE line in let logger = new Uwobo_logger.processingLogger () in + veillogger#clearMsgs; act_on_keys arg styles logger - (fun key -> log_libxslt_msgs logger (styles#reload key)) - (fun () -> log_libxslt_msgs logger styles#reloadAll) + styles#reload (fun () -> styles#reloadAll) styles#keys "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;