(* * Copyright (C) 2003: * Stefano Zacchiroli * for the HELM Team http://helm.cs.unibo.it/ * * This file is part of HELM, an Hypertextual, Electronic * Library of Mathematics, developed at the Computer Science * Department, University of Bologna, Italy. * * HELM is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * HELM is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with HELM; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, * MA 02111-1307, USA. * * For details, see the HELM World-Wide-Web page, * http://helm.cs.unibo.it/ *) open Printf;; open Uwobo_common;; (* debugging settings *) let debug = false ;; 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_media_type = "text/html" ;; let default_encoding = "utf8" ;; let get_media_type props = try List.assoc "media-type" props with Not_found -> default_media_type ;; 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 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 = 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 all_keys logmsg = let keys = try Pcre.split ~pat:"," keys_param with Http_types.Param_not_found _ -> [] in match keys with | [] -> (* no key provided, act on all stylesheets *) 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)); logger#log (sprintf "Done! (stylesheet %s)" key)) keys ;; (** parse parameters for '/apply' action *) let parse_apply_params = let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in List.fold_left (fun (old_params, old_properties) (name, value) -> match name with | name when is_global_param name -> let name = Pcre.replace ~pat:"^param\\." name in ((fun x -> (old_params x) @ [name, value]), old_properties) | name when is_local_param name -> let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in let (key, name) = (pieces.(1), pieces.(2)) in ((function | x when x = key -> [name, value] @ (old_params x) | x -> old_params x), old_properties) | name when is_property name -> let name = Pcre.replace ~pat:"^prop\\." name in (old_params, ((name, value) :: old_properties)) | _ -> (old_params, old_properties)) ((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 *) let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan = (* debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); *) output_string cmd_pipe (cmd ^ "\n"); (* send command to grandfather *) flush cmd_pipe; let res_pipe_fd = Unix.descr_of_in_channel res_pipe in let (read_fds, _, _) = (* wait for an answer *) Unix.select [res_pipe_fd] [] [] 60.0 in (match read_fds with | [fd] when fd = res_pipe_fd -> (* send answer to http client *) Http_daemon.send_basic_headers ~code:(`Code 200) outchan; Http_daemon.send_header "Content-Type" "text/html" outchan; Http_daemon.send_CRLF outchan; (try while true do output_string outchan ((input_line res_pipe) ^ "\n") done with End_of_file -> flush outchan) | _ -> (* no answer received from grandfather *) return_error "Timeout!" outchan) ;; 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 ") ;; (** 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 libxslt_logger = List.iter (function | (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 ) () | 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 @param syslogger Uwobo_logger.sysLogger instance used for logginf @param styles Uwobo_styles.styles instance which keeps the stylesheets list @param cmd_pipe output _channel_ used to _write_ update messages @param res_pipe input _channel_ used to _read_ grandparent results @param req http request instance @param outchan output channel connected to http client *) let callback ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan = try syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr); syslogger#log `Debug (sprintf "Received request: %s" req#path); (match req#path with | "/add" -> (let bindings = req#paramAll "bind" in if bindings = [] then return_error "No [key,stylesheet] binding provided" outchan else begin 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 | "/reload" -> let cmd = sprintf "reload %s" (req#param "keys") in short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan | "/list" -> (let logger = new Uwobo_logger.processingLogger () in (match styles#list with | [] -> logger#log "No stylesheets loaded (yet)!" | l -> 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 (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 *) 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 -> 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:(`Code 200) outchan; Http_daemon.send_header "Content-Type" content_type outchan; Http_daemon.send_CRLF outchan; write_result outchan; close_out outchan with Uwobo_failure errmsg -> return_error ("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 ~code:(`Status (`Client_error `Bad_request)) outchan); syslogger#log `Debug (sprintf "%s done!" req#path); with | Http_types.Param_not_found attr_name -> bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan | exc -> return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan ;; (* UWOBO's startup *) let main () = (* (1) system logger *) let logger_outchan = 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 () in syslogger#enable; (* (2) stylesheets list *) let styles = new Uwobo_styles.styles in (* (3) clean up actions *) let last_process = ref true in let http_child = ref None in let die_nice () = (** at_exit callback *) if !last_process then begin (match !http_child with | None -> () | Some pid -> Unix.kill pid Sys.sigterm); syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name); syslogger#disable; close_out logger_outchan end in at_exit die_nice; ignore (Sys.signal Sys.sigterm (Sys.Signal_handle (fun _ -> raise Sys.Break))); syslogger#log `Notice (sprintf "%s started and listening on port %d" daemon_name port); syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ())); Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *) while true do let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in match Unix.fork () with | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *) http_child := Some child; let stop_http_daemon () = (* kill child *) debug_print (sprintf "UWOBOmaster: killing pid %d" child); Unix.kill child Sys.sigterm; (* kill child ... *) ignore (Unix.waitpid [] child); (* ... and its zombie *) in Unix.close cmd_pipe_entrance; Unix.close res_pipe_exit; let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in (try while true do (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after child process has been killed *) debug_print "UWOBOmaster: waiting for commands ..."; let cmd = input_line cmd_pipe in debug_print (sprintf "UWOBOmaster: received %s command" cmd); (match cmd with (* command from grandchild *) | "test" -> stop_http_daemon (); 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 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] -> logger#log (sprintf "adding binding <%s,%s>" key style); veillogger#clearMsgs; (try veillogger#clearMsgs; styles#add key style; log_libxslt_msgs logger veillogger; with e -> logger#log (Printexc.to_string e)) | _ -> logger#log (sprintf "invalid binding %s" binding)) bindings; 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 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 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 | 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; last_process := false; let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in let res_pipe = Unix.in_channel_of_descr res_pipe_exit in debug_print (sprintf "Starting HTTP daemon on port %d ..." port); (* next invocation doesn't return, process will keep on serving HTTP requests until it will get killed by father *) let d_spec = Http_daemon.daemon_spec ~port ~mode:`Fork ~callback:(callback ~syslogger ~styles ~cmd_pipe ~res_pipe ()) ~auto_close:true () in Http_daemon.main d_spec | _ (* < 0 *) -> (* fork failed :-((( *) failwith "Can't fork :-(" done ;; (* daemon initialization *) try Sys.catch_break true; main () with Sys.Break -> () (* 'die_nice' registered with at_exit *) ;;