X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=inline;f=helm%2Fuwobo%2Fuwobo.ml;h=1a5b44f620264f3c862bc09f3759b25c68dd311c;hb=18c6848695fbfa97508e0981f6875a6459429a58;hp=9dc9b539405f4b5b08480249d5d5ad3edb1e0d9a;hpb=828ef0c1de3cd18634ca2a5070818e521fb5f19e;p=helm.git
diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml
index 9dc9b5394..1a5b44f62 100644
--- a/helm/uwobo/uwobo.ml
+++ b/helm/uwobo/uwobo.ml
@@ -35,27 +35,59 @@ 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
;;
@@ -110,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 *)
@@ -123,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
@@ -135,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
@@ -174,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
@@ -181,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 ("
" ^ 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
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 ->
@@ -237,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 ()
@@ -299,58 +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#keys
+ 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#keys
+ 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;