3 * Stefano Zacchiroli <zack@cs.unibo.it>
4 * for the HELM Team http://helm.cs.unibo.it/
6 * This file is part of HELM, an Hypertextual, Electronic
7 * Library of Mathematics, developed at the Computer Science
8 * Department, University of Bologna, Italy.
10 * HELM is free software; you can redistribute it and/or
11 * modify it under the terms of the GNU General Public License
12 * as published by the Free Software Foundation; either version 2
13 * of the License, or (at your option) any later version.
15 * HELM is distributed in the hope that it will be useful,
16 * but WITHOUT ANY WARRANTY; without even the implied warranty of
17 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 * GNU General Public License for more details.
20 * You should have received a copy of the GNU General Public License
21 * along with HELM; if not, write to the Free Software
22 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
25 * For details, see the HELM World-Wide-Web page,
26 * http://helm.cs.unibo.it/
32 (* debugging settings *)
34 let debug_level = `Notice ;;
35 let debug_print s = if debug then prerr_endline s ;;
36 Http_common.debug := false ;;
38 let configuration_file = "/projects/helm/etc/uwobo.conf.xml";;
40 (* First of all we load the configuration *)
42 Helm_registry.load_from configuration_file
45 let save_configuration () =
46 if not (Helm_registry.has "uwobo.cloned") then
47 Helm_registry.save_to configuration_file
51 let daemon_name = "UWOBO OCaml" ;;
52 let default_media_type = "text/html" ;;
53 let default_encoding = "utf8" ;;
55 let get_media_type props =
57 List.assoc "media-type" props
59 Not_found -> default_media_type
62 let get_encoding props =
64 List.assoc "encoding" props
66 Not_found -> default_encoding
69 let string_of_param_option (req: Http_types.request) name =
73 Http_types.Param_not_found _ -> "#"
75 let string_option_of_string =
80 let port = Helm_registry.get_int "uwobo.port";;
82 let logfilename_of_port port =
83 let basename = Helm_registry.get "uwobo.log_basename" in
84 let extension = Helm_registry.get "uwobo.log_extension" in
85 basename ^ "_" ^ string_of_int port ^ extension
88 let logfile = logfilename_of_port port;;
89 let logfile_perm = 0o640 ;;
91 let respond_html body outchan =
92 Http_daemon.respond ~body ~headers:["Content-Type", "text/html"] outchan
95 (** perform an 'action' that can be applied to a list of keys or, if no keys
96 was given, to all keys *)
98 keys_param styles logger per_key_action all_keys_action all_keys logmsg
102 Pcre.split ~pat:"," keys_param
103 with Http_types.Param_not_found _ -> []
106 | [] -> (* no key provided, act on all stylesheets *)
107 logger#log (sprintf "%s all stylesheets (keys = %s) ..."
108 logmsg (String.concat ", " all_keys));
109 (try all_keys_action () with e -> logger#log (Printexc.to_string e));
110 logger#log (sprintf "Done! (all stylesheets)")
113 (fun key -> (* act on a single stylesheet *)
114 logger#log (sprintf "%s stylesheet %s" logmsg key);
115 (try per_key_action key with e -> logger#log (Printexc.to_string e));
116 logger#log (sprintf "Done! (stylesheet %s)" key))
120 (** parse parameters for '/apply' action *)
121 let parse_apply_params =
122 let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
123 let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
124 let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
126 (fun (old_params, old_properties) (name, value) ->
128 | name when is_global_param name ->
129 let name = Pcre.replace ~pat:"^param\\." name in
130 ((fun x -> (old_params x) @ [name, value]), old_properties)
131 | name when is_local_param name ->
132 let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
133 let (key, name) = (pieces.(1), pieces.(2)) in
135 | x when x = key -> [name, value] @ (old_params x)
136 | x -> old_params x),
138 | name when is_property name ->
139 let name = Pcre.replace ~pat:"^prop\\." name in
140 (old_params, ((name, value) :: old_properties))
141 | _ -> (old_params, old_properties))
142 ((fun _ -> []), []) (* no parameters, no properties *)
145 (** Parse libxslt's message modes for error and debugging messages. Default is
146 to ignore mesages of both kind *)
147 let parse_libxslt_msgs_mode (req: Http_types.request) =
149 (match req#param "errormode" with
150 | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
151 | s when String.lowercase s = "comment" -> LibXsltMsgComment
152 | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
156 "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
157 err "errormode" "ignore" "comment")))
158 with Http_types.Param_not_found _ -> LibXsltMsgIgnore),
160 (match req#param "debugmode" with
161 | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
162 | s when String.lowercase s = "comment" -> LibXsltMsgComment
163 | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
167 "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
168 err "debugmode" "ignore" "comment")))
169 with Http_types.Param_not_found _ -> LibXsltMsgIgnore))
172 (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer
173 on ~res_pipe (with a timeout of 60 seconds) and send over outchan data
174 received from ~res_pipe *)
175 let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
176 (* debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); *)
177 output_string cmd_pipe (cmd ^ "\n"); (* send command to grandfather *)
179 let res_pipe_fd = Unix.descr_of_in_channel res_pipe in
180 let (read_fds, _, _) = (* wait for an answer *)
181 Unix.select [res_pipe_fd] [] [] 60.0
184 | [fd] when fd = res_pipe_fd -> (* send answer to http client *)
185 Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
186 Http_daemon.send_header "Content-Type" "text/html" outchan;
187 Http_daemon.send_CRLF outchan;
190 output_string outchan ((input_line res_pipe) ^ "\n")
192 with End_of_file -> flush outchan)
193 | _ -> (* no answer received from grandfather *)
194 return_error "Timeout!" outchan)
197 let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE, kill_cmd_RE,
198 createprofile_cmd_RE, removeprofile_cmd_RE, setprofileparam_cmd_RE,
199 setparams_cmd_RE, setpassword_cmd_RE, setpermission_cmd_RE) =
200 (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ",
201 Pcre.regexp "^kill", Pcre.regexp "^createprofile ", Pcre.regexp "^removeprofile ",
202 Pcre.regexp "^setprofileparam ",
203 Pcre.regexp "^setparams ", Pcre.regexp "^setpassword ", Pcre.regexp "^setpermission ")
206 (** raised by child processes when HTTP daemon process have to be restarted *)
207 exception Restart_HTTP_daemon ;;
209 (** log a list of libxslt's messages using a processing logger *)
210 let log_libxslt_msgs logger libxslt_logger =
213 | (LibXsltErrorMsg _) as msg -> logger#logBold (string_of_xslt_msg msg)
214 | (LibXsltDebugMsg _) as msg -> logger#logEmph (string_of_xslt_msg msg))
219 let veillogger = new Uwobo_common.libXsltLogger ;;
221 (* start_new_session cmd_pipe_exit res_pipe_entrance outchan port logfile
222 @param cmd_pipe Pipe to be closed before forking
223 @param res_pipe Pipe to be closed before forking
224 @param outchan To be closed before forking
225 @param port The port to be used
226 @param logfile The logfile to redirect the stdout and sterr to
228 (* It can raise Failure "Connection refused" *)
229 (* It can raise Failure "Port already in use" *)
230 let start_new_session cmd_pipe res_pipe outchan port logfile =
231 (* Let's check that the port is free *)
234 (Http_client.http_get
235 ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ;
236 raise (Failure "Port already in use")
238 Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> ()
240 match Unix.fork () with
242 Unix.handle_unix_error
244 (* 1. We close all the open pipes to avoid duplicating them *)
245 Unix.close (Unix.descr_of_out_channel cmd_pipe) ;
246 Unix.close (Unix.descr_of_in_channel res_pipe) ;
247 Unix.close (Unix.descr_of_out_channel outchan) ;
248 (* 2. We redirect stdout and stderr to the logfile *)
249 Unix.close Unix.stdout ;
251 (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
252 0o664 = Unix.stdout) ;
253 Unix.close Unix.stderr ;
255 (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
256 0o664 = Unix.stderr) ;
257 prerr_endline "***** Starting a new session" ;
259 (* 3. We set up a new environment *)
261 (* Here I am loosing the current value of port_env_var; *)
262 (* this should not matter *)
263 Unix.putenv "uwobo__port" (string_of_int port) ;
264 Unix.putenv "uwobo__cloned" "1" ;
267 (* 4. We exec a new copy of uwobo *)
268 Unix.execve Sys.executable_name [||] environment ;
269 (* It should never reach this point *)
272 | child when child > 0 ->
273 (* let's check if the new UWOBO started correctly *)
275 (* It can raise Failure "Connection refused" *)
278 (Http_client.http_get
279 ("http://127.0.0.1:" ^ string_of_int port ^ "/help"))
280 with Unix.Unix_error (Unix.ECONNREFUSED, _, _) ->
281 raise (Failure "Connection refused"))
282 | _ -> failwith "Can't fork :-("
285 (* request handler action
286 @param syslogger Uwobo_logger.sysLogger instance used for logginf
287 @param styles Uwobo_styles.styles instance which keeps the stylesheets list
288 @param cmd_pipe output _channel_ used to _write_ update messages
289 @param res_pipe input _channel_ used to _read_ grandparent results
290 @param req http request instance
291 @param outchan output channel connected to http client
294 ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
297 syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
298 syslogger#log `Debug (sprintf "Received request: %s" req#path);
301 (let bindings = req#paramAll "bind" in
302 if bindings = [] then
303 return_error "No [key,stylesheet] binding provided" outchan
305 let cmd = sprintf "add %s" (String.concat ";" bindings) in
306 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
309 let logger = new Uwobo_logger.processingLogger () in
310 logger#log "Exiting" ;
311 respond_html logger#asHtml outchan ;
313 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
315 let logger = new Uwobo_logger.processingLogger () in
316 let port = int_of_string (req#param "port") in
317 let logfile = logfilename_of_port port in
319 start_new_session cmd_pipe res_pipe outchan port logfile ;
320 logger#log (sprintf "New session started: port = %d" port) ;
321 respond_html logger#asHtml outchan
323 Failure "int_of_string" ->
324 logger#log (sprintf "Invalid port number") ;
325 respond_html logger#asHtml outchan
326 | Failure "Port already in use" ->
327 Uwobo_common.return_error "port already in use" outchan
328 | Failure "Connection refused" ->
331 let ch = open_in logfile in
332 while true do log := (input_line ch ^ "\n") :: !log ; done
337 let rec get_last_lines acc =
339 (n,he::tl) when n > 0 ->
340 get_last_lines (he ^ "<br />" ^ acc) (n-1,tl)
343 (* we just show the last 10 lines of the log file *)
345 (if List.length !log > 0 then "<br />...<br />" else "<br />") ^
346 get_last_lines "" (10,!log)
348 Uwobo_common.return_error "daemon not initialized"
351 let cmd = sprintf "remove %s" (req#param "keys") in
352 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
354 let cmd = sprintf "reload %s" (req#param "keys") in
355 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
357 (let logger = new Uwobo_logger.processingLogger () in
358 (match styles#list with
359 | [] -> logger#log "No stylesheets loaded (yet)!"
361 logger#log "Stylesheets list:";
362 List.iter (fun s -> logger#log s) l);
363 respond_html logger#asHtml outchan)
365 let profile_list = Uwobo_profiles.list () in
366 respond_html ("<html><body><ul>" ^ String.concat "" (List.map (fun s -> "<li>" ^ s ^ "</li>") profile_list) ^ "</ul></body></html>") outchan
367 | "/createprofile" ->
368 let cmd = sprintf "createprofile %s,%s,%s,%s,%s,%s,%s"
369 (string_of_param_option req "id")
370 (string_of_param_option req "orig")
371 (string_of_param_option req "origpassword")
372 (string_of_param_option req "readperm")
373 (string_of_param_option req "writeperm")
374 (string_of_param_option req "adminperm")
375 (string_of_param_option req "password")
377 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
378 | "/removeprofile" ->
379 let cmd = sprintf "removeprofile %s,%s"
381 (string_of_param_option req "password")
383 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
385 let cmd = sprintf "setprofileparam %s,%s,%s,%s"
386 (string_of_param_option req "id")
387 (string_of_param_option req "password")
389 (string_of_param_option req "value")
391 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
393 let cmd = sprintf "setpassword %s,%s,%s"
395 (string_of_param_option req "oldpassword")
396 (string_of_param_option req "password")
398 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
399 | "/setpermission" ->
401 match req#param "for" with
404 | "admin" as forwhat ->
405 let cmd = sprintf "setpermission %s,%s,%s,%s"
407 (string_of_param_option req "password")
411 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
412 | _ -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan
415 let pid = req#param "id" in
416 let password = try Some (req#param "password") with _ -> None in
417 let res = Uwobo_profiles.get_params pid ?password () in
419 ("<html><body><ul>" ^
420 String.concat "" (List.map (fun k,v -> "<li><key>" ^ k ^ "</key> = <value>" ^ v ^ "</value></li>") res) ^
421 "</ul></body></html>") outchan
423 let is_global_param = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" in
424 let is_local_param = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" in
425 let param_value_list =
427 (fun (param, _) -> (is_global_param param) || (is_local_param param))
430 let serialized_param_value_list =
432 (fun (param, value) -> (Pcre.replace ~pat:"^param\\." param) ^ "=" ^ value)
435 let cmd = sprintf "setparams %s,%s,%s"
437 (string_of_param_option req "password")
438 (String.concat "," serialized_param_value_list)
440 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
442 let pid = req#param "id" in
443 let password = try Some (req#param "password") with _ -> None in
444 let key = req#param "key" in
445 let value = Uwobo_profiles.get_param pid ?password ~key () in
446 respond_html ("<html><body>" ^ value ^ "</body></html>") outchan
447 | "/getpermission" ->
448 let pid = req#param "id" in
449 let password = try Some (req#param "password") with _ -> None in
451 match req#param "for" with
453 | "write" -> Some `Write
454 | "admin" -> Some `Admin
460 let value = Uwobo_profiles.get_permission pid ?password forwhat in
461 respond_html ("<html><body>" ^ (if value then "public" else "private") ^ "</body></html>") outchan
462 | None -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan ;
465 let logger = new Uwobo_logger.processingLogger () in
466 veillogger#clearMsgs;
467 let profile = try Some (req#param "profile") with _ -> None in
468 let password = try Some (req#param "password") with _ -> None in
469 let xmluri = req#param "xmluri" in
470 let keys = Pcre.split ~pat:"," (req#param "keys") in
471 (* notation: "local" parameters are those defined on a per-stylesheet
472 pasis (i.e. param.key.param=value), "global" parameters are those
473 defined for all stylesheets (i.e. param.param=value) *)
474 let (user_params, props) = parse_apply_params req#params in
478 | Some profile -> Uwobo_profiles.get_params profile ?password () in
480 (* user provided parameters override the profile parameters *)
481 let is_global_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){1}$" ("." ^ x) in
482 let is_local_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){2}$" ("." ^ x) in
483 let add key value params =
484 if List.mem_assoc key params then params else params @ [key,value]
487 (fun old_params (name, value) ->
489 | name when is_global_param name ->
490 (fun x -> add name value (old_params x))
491 | name when is_local_param name ->
492 let pieces = Pcre.extract ~pat:"^([^.]+)\\.(.*)" name in
493 let (key, name) = (pieces.(1), pieces.(2)) in
495 | x when x = key -> add name value (old_params x)
498 user_params profile_params
500 let (libxslt_errormode, libxslt_debugmode) =
501 parse_libxslt_msgs_mode req
503 syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
504 let domImpl = Gdome.domImplementation () in
505 let input = domImpl#createDocumentFromURI ~uri:xmluri () in
506 syslogger#log `Debug "Applying stylesheet chain ...";
508 let (write_result, media_type, encoding) = (* out_channel -> unit *)
510 ~logger:syslogger ~styles ~keys ~params ~props ~veillogger
511 ~errormode:libxslt_errormode ~debugmode:libxslt_debugmode
514 let content_type = (* value of Content-Type HTTP response header *)
515 sprintf "%s; charset=%s"
516 (match media_type with None -> get_media_type props | Some t -> t)
517 (match encoding with None -> get_encoding props | Some e -> e)
520 (sprintf "sending output to client (Content-Type: %s)...."
522 Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
523 Http_daemon.send_header "Content-Type" content_type outchan;
524 Http_daemon.send_CRLF outchan;
526 with Uwobo_failure errmsg ->
528 ("Stylesheet chain application failed: " ^ errmsg)
529 ~body: ("<h2>LibXSLT's messages:</h2>" ^
530 String.concat "<br />\n"
531 (List.map string_of_xslt_msg veillogger#msgs))
533 | "/help" -> respond_html usage_string outchan
535 Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan);
536 syslogger#log `Debug (sprintf "%s done!" req#path);
538 | Http_types.Param_not_found attr_name ->
539 bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
541 return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
544 (* UWOBO's startup *)
546 (* (1) system logger *)
548 debug_print (sprintf "Logging to file %s" logfile);
549 open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm logfile
552 new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
555 (* (2) stylesheets list *)
556 let styles = new Uwobo_styles.styles in
557 (* (3) clean up actions *)
558 let last_process = ref true in
559 let http_child = ref None in
560 let die_nice () = (** at_exit callback *)
561 if !last_process then begin
562 (match !http_child with
564 | Some pid -> Unix.kill pid Sys.sigterm);
565 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
567 close_out logger_outchan
571 ignore (Sys.signal Sys.sigterm
572 (Sys.Signal_handle (fun _ -> raise Sys.Break)));
573 syslogger#log `Notice
574 (sprintf "%s started and listening on port %d" daemon_name port);
575 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
576 Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *)
578 let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
579 let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
580 match Unix.fork () with
581 | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *)
582 http_child := Some child;
583 let stop_http_daemon () = (* kill child *)
584 debug_print (sprintf "UWOBOmaster: killing pid %d" child);
585 Unix.kill child Sys.sigterm; (* kill child ... *)
586 ignore (Unix.waitpid [] child); (* ... and its zombie *)
588 Unix.close cmd_pipe_entrance;
589 Unix.close res_pipe_exit;
590 let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
591 let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
594 (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
595 child process has been killed *)
596 debug_print "UWOBOmaster: waiting for commands ...";
597 let cmd = input_line cmd_pipe in
598 debug_print (sprintf "UWOBOmaster: received %s command" cmd);
599 (match cmd with (* command from grandchild *)
602 output_string res_pipe "UWOBOmaster: Hello, world!\n";
604 raise Restart_HTTP_daemon
605 | line when Pcre.pmatch ~rex:kill_cmd_RE line -> (* /kill *)
607 | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *)
609 Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line)
612 let logger = new Uwobo_logger.processingLogger () in
614 (fun binding -> (* add a <key, stylesheet> binding *)
615 let pieces = Pcre.split ~pat:"," binding in
618 logger#log (sprintf "adding binding <%s,%s>" key style);
619 veillogger#clearMsgs;
621 veillogger#clearMsgs;
622 styles#add key style;
623 log_libxslt_msgs logger veillogger;
625 logger#log (Printexc.to_string e))
626 | _ -> logger#log (sprintf "invalid binding %s" binding))
628 output_string res_pipe logger#asHtml;
630 raise Restart_HTTP_daemon
631 | line when Pcre.pmatch ~rex:remove_cmd_RE line -> (* /remove *)
633 let arg = Pcre.replace ~rex:remove_cmd_RE line in
634 let logger = new Uwobo_logger.processingLogger () in
635 veillogger#clearMsgs;
638 styles#remove (fun () -> styles#removeAll) styles#keys
640 log_libxslt_msgs logger veillogger;
641 output_string res_pipe (logger#asHtml);
642 raise Restart_HTTP_daemon
643 | line when Pcre.pmatch ~rex:reload_cmd_RE line -> (* /reload *)
645 let arg = Pcre.replace ~rex:reload_cmd_RE line in
646 let logger = new Uwobo_logger.processingLogger () in
647 veillogger#clearMsgs;
650 styles#reload (fun () -> styles#reloadAll) styles#keys
652 output_string res_pipe (logger#asHtml);
653 raise Restart_HTTP_daemon
654 | line when Pcre.pmatch ~rex:createprofile_cmd_RE line -> (* /createprofile *)
657 List.map string_option_of_string (Pcre.split ~pat:"," (Pcre.replace ~rex:createprofile_cmd_RE line))
661 [id; clone; clone_password; read_perm; write_perm; admin_perm; password] ->
662 let bool_option_of_string_option =
664 Some "true" -> Some true
665 | Some _ -> Some false
669 Uwobo_profiles.create
673 ?read_perm:(bool_option_of_string_option read_perm)
674 ?write_perm:(bool_option_of_string_option write_perm)
675 ?admin_perm:(bool_option_of_string_option admin_perm)
679 save_configuration () ;
680 output_string res_pipe ("Profile " ^ pid ^ " created. Hi " ^ pid) ;
681 raise Restart_HTTP_daemon
684 | line when Pcre.pmatch ~rex:removeprofile_cmd_RE line -> (* /removeprofile *)
687 match Pcre.split ~pat:"," (Pcre.replace ~rex:removeprofile_cmd_RE line) with
688 [pid; password] -> pid, (string_option_of_string password)
691 Uwobo_profiles.remove pid ?password () ;
692 save_configuration () ;
693 output_string res_pipe "Done" ;
694 raise Restart_HTTP_daemon
695 | line when Pcre.pmatch ~rex:setparams_cmd_RE line -> (* /setparams *)
696 stop_http_daemon () ;
697 let pid, password, pv_list =
698 match Pcre.split ~pat:"," (Pcre.replace ~rex:setparams_cmd_RE line) with
699 pid::password::pv_list ->
700 pid, (string_option_of_string password),
703 match Pcre.split ~pat:"=" pv with
705 | [key; value] -> (key, Some value)
711 (fun (key, value) -> Uwobo_profiles.set_param pid ?password ~key ~value ())
713 save_configuration () ;
714 output_string res_pipe "Done" ;
715 raise Restart_HTTP_daemon
716 | line when Pcre.pmatch ~rex:setprofileparam_cmd_RE line -> (* /setprofileparam *)
718 let pid, password, key, value =
719 match Pcre.split ~pat:"," (Pcre.replace ~rex:setprofileparam_cmd_RE line) with
720 [pid; password; key; value] ->
721 pid, (string_option_of_string password), key, (string_option_of_string value)
724 Uwobo_profiles.set_param pid ?password ~key ~value () ;
725 save_configuration () ;
726 output_string res_pipe "Done" ;
727 raise Restart_HTTP_daemon
728 | line when Pcre.pmatch ~rex:setpassword_cmd_RE line -> (* /setpassword *)
730 let pid, old_password, password =
731 match Pcre.split ~pat:"," (Pcre.replace ~rex:setpassword_cmd_RE line) with
732 [pid; old_password; password] ->
733 pid, (string_option_of_string old_password), (string_option_of_string password)
736 Uwobo_profiles.set_password pid ?old_password password ;
737 save_configuration () ;
738 output_string res_pipe "Done" ;
739 raise Restart_HTTP_daemon
740 | line when Pcre.pmatch ~rex:setpermission_cmd_RE line -> (* /setpermission *)
742 let permission_of_string =
748 and bool_of_string s = "public" = s
750 let pid, password, forwhat, value =
751 match Pcre.split ~pat:"," (Pcre.replace ~rex:setpermission_cmd_RE line) with
752 [pid; password; forwhat; value] ->
753 pid, (string_option_of_string password), (permission_of_string forwhat), (bool_of_string value)
756 Uwobo_profiles.set_permission pid ?password forwhat value ;
757 save_configuration () ;
758 output_string res_pipe "Done" ;
759 raise Restart_HTTP_daemon
760 | cmd -> (* invalid interprocess command received *)
761 syslogger#log `Warning
762 (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
765 Restart_HTTP_daemon ->
766 close_in cmd_pipe; (* these calls close also fds *)
768 | e -> (* Should we return a 404 error here? Maybe... (how?) *)
769 output_string res_pipe (Printexc.to_string e);
770 close_in cmd_pipe; (* these calls close also fds *)
772 | 0 -> (* (5) child: serve http requests *)
773 Unix.close cmd_pipe_exit;
774 Unix.close res_pipe_entrance;
775 last_process := false;
776 let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in
777 let res_pipe = Unix.in_channel_of_descr res_pipe_exit in
778 debug_print (sprintf "Starting HTTP daemon on port %d ..." port);
779 (* next invocation doesn't return, process will keep on serving HTTP
780 requests until it will get killed by father *)
781 Http_daemon.start'~port ~mode:`Fork
782 (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
783 | _ (* < 0 *) -> (* fork failed :-((( *)
784 failwith "Can't fork :-("
788 (* daemon initialization *)
790 Sys.catch_break true;
792 with Sys.Break -> () (* 'die_nice' registered with at_exit *)