]> matita.cs.unibo.it Git - helm.git/blob - helm/uwobo/uwobo.ml
tex notation for compatibility with texTermEditor
[helm.git] / helm / uwobo / uwobo.ml
1 (*
2  * Copyright (C) 2003:
3  *    Stefano Zacchiroli <zack@cs.unibo.it>
4  *    for the HELM Team http://helm.cs.unibo.it/
5  *
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.
9  *
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.
14  *
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.
19  *
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,
23  *  MA  02111-1307, USA.
24  *
25  *  For details, see the HELM World-Wide-Web page,
26  *  http://helm.cs.unibo.it/
27  *)
28
29 open Printf;;
30 open Uwobo_common;;
31
32  (* debugging settings *)
33 let debug = false ;;
34 let debug_level = `Notice ;;
35 let debug_print s = if debug then prerr_endline s ;;
36 Http_common.debug := false ;;
37
38   (* other settings *)
39 let daemon_name = "UWOBO OCaml" ;;
40 let default_log_base_file = "log/uwobo" ;; (* relative to execution dir *)
41 let log_extension = ".log" ;;
42 let default_port = 58080 ;;
43 let port_env_var = "UWOBO_PORT" ;;
44 let log_env_var = "UWOBO_LOG_FILE" ;; (* The extension _pid.log will be added *)
45 let default_media_type = "text/html" ;;
46 let default_encoding = "utf8" ;;
47
48 let get_media_type props =
49  try
50   List.assoc "media-type" props
51  with
52   Not_found -> default_media_type
53 ;;
54
55 let get_encoding props =
56  try
57   List.assoc "encoding" props
58  with
59   Not_found -> default_encoding
60 ;;
61
62 let port =
63   try
64     int_of_string (Sys.getenv port_env_var)
65   with
66   | Not_found -> default_port
67   | Failure "int_of_string" ->
68      prerr_endline "Warning: invalid port number" ;
69      exit (-1)
70 ;;
71 let logfilename_of_port port =
72  let basename =
73   try
74    Sys.getenv log_env_var
75   with
76    Not_found -> default_log_base_file
77  in
78   basename ^ "_" ^ string_of_int port ^ log_extension
79 ;;
80 let logfile = logfilename_of_port port;;
81 let logfile_perm = 0o640 ;;
82
83 let respond_html body outchan =
84   Http_daemon.respond ~body ~headers:["Content-Type", "text/html"] outchan
85 ;;
86
87   (** perform an 'action' that can be applied to a list of keys or, if no keys
88   was given, to all keys *)
89 let act_on_keys
90   keys_param styles logger per_key_action all_keys_action all_keys logmsg
91 =
92   let keys =
93     try
94       Pcre.split ~pat:"," keys_param
95     with Http_types.Param_not_found _ -> []
96   in
97   match keys with
98   | [] -> (* no key provided, act on all stylesheets *)
99       logger#log (sprintf "%s all stylesheets (keys = %s) ..."
100         logmsg (String.concat ", " all_keys));
101       (try all_keys_action () with e -> logger#log (Printexc.to_string e));
102       logger#log (sprintf "Done! (all stylesheets)")
103   | keys ->
104       List.iter
105         (fun key -> (* act on a single stylesheet *)
106           logger#log (sprintf "%s stylesheet %s" logmsg key);
107           (try per_key_action key with e -> logger#log (Printexc.to_string e));
108           logger#log (sprintf "Done! (stylesheet %s)" key))
109         keys
110 ;;
111
112   (** parse parameters for '/apply' action *)
113 let parse_apply_params =
114   let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
115   let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
116   let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
117   List.fold_left
118     (fun (old_params, old_properties) (name, value) ->
119       match name with
120       | name when is_global_param name ->
121           let name = Pcre.replace ~pat:"^param\\." name in
122           ((fun x -> (old_params x) @ [name, value]), old_properties)
123       | name when is_local_param name ->
124           let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
125           let (key, name) = (pieces.(1), pieces.(2)) in
126           ((function
127             | x when x = key -> [name, value] @ (old_params x)
128             | x -> old_params x),
129            old_properties)
130       | name when is_property name ->
131           let name = Pcre.replace ~pat:"^prop\\." name in
132           (old_params, ((name, value) :: old_properties))
133       | _ -> (old_params, old_properties))
134     ((fun _ -> []), []) (* no parameters, no properties *)
135 ;;
136
137   (** Parse libxslt's message modes for error and debugging messages. Default is
138   to ignore mesages of both kind *)
139 let parse_libxslt_msgs_mode (req: Http_types.request) =
140   ((try
141     (match req#param "errormode" with
142     | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
143     | s when String.lowercase s = "comment" -> LibXsltMsgComment
144     | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
145     | err ->
146         raise (Uwobo_failure
147           (sprintf
148             "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
149             err "errormode" "ignore" "comment")))
150   with Http_types.Param_not_found _ -> LibXsltMsgIgnore),
151   (try
152     (match req#param "debugmode" with
153     | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
154     | s when String.lowercase s = "comment" -> LibXsltMsgComment
155     | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
156     | err ->
157         raise (Uwobo_failure
158           (sprintf
159             "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
160             err "debugmode" "ignore" "comment")))
161   with Http_types.Param_not_found _ -> LibXsltMsgIgnore))
162 ;;
163
164   (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer
165   on ~res_pipe (with a timeout of 60 seconds) and send over outchan data
166   received from ~res_pipe *)
167 let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
168 (*   debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); *)
169   output_string cmd_pipe (cmd ^ "\n");  (* send command to grandfather *)
170   flush cmd_pipe;
171   let res_pipe_fd = Unix.descr_of_in_channel res_pipe in
172   let (read_fds, _, _) =  (* wait for an answer *)
173     Unix.select [res_pipe_fd] [] [] 60.0
174   in
175   (match read_fds with
176   | [fd] when fd = res_pipe_fd -> (* send answer to http client *)
177       Http_daemon.send_basic_headers ~code:200 outchan;
178       Http_daemon.send_header "Content-Type" "text/html" outchan;
179       Http_daemon.send_CRLF outchan;
180       (try
181         while true do
182           output_string outchan ((input_line res_pipe) ^ "\n")
183         done
184       with End_of_file -> flush outchan)
185   | _ ->  (* no answer received from grandfather *)
186       return_error "Timeout!" outchan)
187 ;;
188
189 let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE, kill_cmd_RE) =
190   (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ",
191    Pcre.regexp "^kill")
192 ;;
193
194   (** raised by child processes when HTTP daemon process have to be restarted *)
195 exception Restart_HTTP_daemon ;;
196
197   (** log a list of libxslt's messages using a processing logger *)
198 let log_libxslt_msgs logger libxslt_logger =
199   List.iter
200     (function
201       | (LibXsltErrorMsg _) as msg -> logger#logBold (string_of_xslt_msg msg)
202       | (LibXsltDebugMsg _) as msg -> logger#logEmph (string_of_xslt_msg msg))
203     libxslt_logger#msgs
204 ;;
205
206   (* LibXSLT logger *)
207 let veillogger = new Uwobo_common.libXsltLogger ;;
208
209   (* start_new_session cmd_pipe_exit res_pipe_entrance outchan port logfile
210   @param cmd_pipe Pipe to be closed before forking
211   @param res_pipe Pipe to be closed before forking
212   @param outchan  To be closed before forking
213   @param port The port to be used
214   @param logfile The logfile to redirect the stdout and sterr to
215   *)
216   (* It can raise Failure "Connection refused" *)
217   (* It can raise Failure "Port already in use" *)
218 let start_new_session cmd_pipe res_pipe outchan port logfile =
219  let environment =
220   (* Here I am loosing the current value of port_env_var; *)
221   (* this should not matter                               *)
222   Unix.putenv port_env_var (string_of_int port) ;
223   Unix.environment ()
224  in
225   (* Let's check that the port is free *)
226   (try
227     ignore
228      (Http_client.http_get
229        ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ;
230     raise (Failure "Port already in use")
231    with
232     Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> ()
233   ) ;
234   match Unix.fork () with
235      0 ->
236        Unix.handle_unix_error
237         (function () ->
238           (* 1. We close all the open pipes to avoid duplicating them *)
239           Unix.close (Unix.descr_of_out_channel cmd_pipe) ;
240           Unix.close (Unix.descr_of_in_channel res_pipe) ;
241           Unix.close (Unix.descr_of_out_channel outchan) ;
242           (* 2. We redirect stdout and stderr to the logfile *)
243           Unix.close Unix.stdout ;
244           assert
245            (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
246              0o664 = Unix.stdout) ;
247           Unix.close Unix.stderr ;
248           assert
249            (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
250              0o664 = Unix.stderr) ;
251           prerr_endline "***** Starting a new session" ;
252           (* 3. We exec a new copy of uwobo *)
253           Unix.execve Sys.executable_name [||] environment ; 
254           (* It should never reach this point *)
255           assert false
256         ) ()
257    | child when child > 0 ->
258       (* let's check if the new UWOBO started correctly *)
259       Unix.sleep 5 ;
260       (* It can raise Failure "Connection refused" *)
261       (try
262         ignore
263           (Http_client.http_get
264             ("http://127.0.0.1:" ^ string_of_int port ^ "/help"))
265       with Unix.Unix_error (Unix.ECONNREFUSED, _, _) ->
266         raise (Failure "Connection refused"))
267    | _ -> failwith "Can't fork :-("
268 ;;
269
270   (* request handler action
271   @param syslogger Uwobo_logger.sysLogger instance used for logginf
272   @param styles Uwobo_styles.styles instance which keeps the stylesheets list
273   @param cmd_pipe output _channel_ used to _write_ update messages
274   @param res_pipe input _channel_ used to _read_ grandparent results
275   @param req http request instance
276   @param outchan output channel connected to http client
277   *)
278 let callback
279   ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
280   =
281   try
282     syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
283     syslogger#log `Debug (sprintf "Received request: %s" req#path);
284     (match req#path with
285     | "/add" ->
286         (let bindings = req#paramAll "bind" in
287         if bindings = [] then
288           return_error "No [key,stylesheet] binding provided" outchan
289         else begin
290           let cmd = sprintf "add %s" (String.concat ";" bindings) in
291           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
292         end)
293     | "/kill" ->
294         let logger = new Uwobo_logger.processingLogger () in
295          logger#log "Exiting" ;
296          respond_html logger#asHtml outchan ;
297          let cmd = "kill" in
298           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
299     | "/newsession" ->
300         let logger = new Uwobo_logger.processingLogger () in
301         let port = int_of_string (req#param "port") in
302         let logfile = logfilename_of_port port in
303         (try
304           start_new_session cmd_pipe res_pipe outchan port logfile ;
305           logger#log (sprintf "New session started: port = %d" port) ;
306           respond_html logger#asHtml outchan
307          with
308             Failure "int_of_string" ->
309              logger#log (sprintf "Invalid port number") ;
310              respond_html logger#asHtml outchan
311           | Failure "Port already in use" ->
312              Uwobo_common.return_error "port already in use" outchan
313           | Failure "Connection refused" ->
314              let log = ref [] in
315               (try
316                 let ch = open_in logfile in
317                  while true do log := (input_line ch ^ "\n") :: !log ; done
318                with
319                   Sys_error _
320                 | End_of_file -> ()
321               ) ;
322               let rec get_last_lines acc =
323                function
324                   (n,he::tl) when n > 0 ->
325                     get_last_lines (he ^ "<br />" ^ acc) (n-1,tl)
326                 | _ -> acc
327               in
328                (* we just show the last 10 lines of the log file *)
329                let msg =
330                 (if List.length !log > 0 then "<br />...<br />" else "<br />") ^
331                  get_last_lines "" (10,!log)
332                in
333                 Uwobo_common.return_error "daemon not initialized"
334                  ~body:msg outchan)
335     | "/remove" ->
336           let cmd = sprintf "remove %s" (req#param "keys") in
337           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
338     | "/reload" ->
339           let cmd = sprintf "reload %s" (req#param "keys") in
340           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
341     | "/list" ->
342         (let logger = new Uwobo_logger.processingLogger () in
343         (match styles#list with
344         | [] -> logger#log "No stylesheets loaded (yet)!"
345         | l ->
346             logger#log "Stylesheets list:";
347             List.iter (fun s -> logger#log s) l);
348         respond_html logger#asHtml outchan)
349     | "/apply" ->
350         let logger = new Uwobo_logger.processingLogger () in
351         veillogger#clearMsgs;
352         let xmluri = req#param "xmluri" in
353         let keys = Pcre.split ~pat:"," (req#param "keys") in
354         (* notation: "local" parameters are those defined on a per-stylesheet
355         pasis (i.e. param.key.param=value), "global" parameters are those
356         defined for all stylesheets (i.e. param.param=value) *)
357         let (params, props) = parse_apply_params req#params in
358         let (libxslt_errormode, libxslt_debugmode) =
359           parse_libxslt_msgs_mode req
360         in
361         syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
362         let domImpl = Gdome.domImplementation () in
363         let input = domImpl#createDocumentFromURI ~uri:xmluri () in
364         syslogger#log `Debug "Applying stylesheet chain ...";
365         (try
366           let (write_result, media_type, encoding) = (* out_channel -> unit *)
367             Uwobo_engine.apply
368               ~logger:syslogger ~styles ~keys ~params ~props ~veillogger
369               ~errormode:libxslt_errormode ~debugmode:libxslt_debugmode
370               input
371           in
372           let content_type = (* value of Content-Type HTTP response header *)
373             sprintf "%s; charset=%s"
374               (match media_type with None -> get_media_type props | Some t -> t)
375               (match encoding with None -> get_encoding props | Some e -> e)
376           in
377           syslogger#log `Debug
378             (sprintf "sending output to client (Content-Type: %s)...."
379               content_type);
380           Http_daemon.send_basic_headers ~code:200 outchan;
381           Http_daemon.send_header "Content-Type" content_type outchan;
382           Http_daemon.send_CRLF outchan;
383           write_result outchan
384         with Uwobo_failure errmsg ->
385           return_error
386             ("Stylesheet chain application failed: " ^ errmsg)
387             ~body: ("<h2>LibXSLT's messages:</h2>" ^
388               String.concat "<br />\n"
389                 (List.map string_of_xslt_msg veillogger#msgs))
390             outchan)
391     | "/help" -> respond_html usage_string outchan
392     | invalid_request ->
393         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
394     syslogger#log `Debug (sprintf "%s done!" req#path);
395   with
396   | Http_types.Param_not_found attr_name ->
397       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
398   | exc ->
399       return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
400 ;;
401
402   (* UWOBO's startup *)
403 let main () =
404     (* (1) system logger *)
405   let logger_outchan =
406    debug_print (sprintf "Logging to file %s" logfile);
407    open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm logfile
408   in
409   let syslogger =
410     new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
411   in
412   syslogger#enable;
413     (* (2) stylesheets list *)
414   let styles = new Uwobo_styles.styles in
415     (* (3) clean up actions *)
416   let last_process = ref true in
417   let http_child = ref None in
418   let die_nice () = (** at_exit callback *)
419     if !last_process then begin
420       (match !http_child with
421       | None -> ()
422       | Some pid -> Unix.kill pid Sys.sigterm);
423       syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
424       syslogger#disable;
425       close_out logger_outchan
426     end
427   in
428   at_exit die_nice;
429   ignore (Sys.signal Sys.sigterm
430     (Sys.Signal_handle (fun _ -> raise Sys.Break)));
431   syslogger#log `Notice
432     (sprintf "%s started and listening on port %d" daemon_name port);
433   syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
434   Unix.putenv "http_proxy" "";  (* reset http_proxy to avoid libxslt problems *)
435   while true do
436     let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
437     let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
438     match Unix.fork () with
439     | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *)
440         http_child := Some child;
441         let stop_http_daemon () =  (* kill child *)
442           debug_print (sprintf "UWOBOmaster: killing pid %d" child);
443           Unix.kill child Sys.sigterm;  (* kill child ... *)
444           ignore (Unix.waitpid [] child);  (* ... and its zombie *)
445         in
446         Unix.close cmd_pipe_entrance;
447         Unix.close res_pipe_exit;
448         let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
449         let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
450         (try
451           while true do
452             (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
453             child process has been killed *)
454             debug_print "UWOBOmaster: waiting for commands ...";
455             let cmd = input_line cmd_pipe in
456             debug_print (sprintf "UWOBOmaster: received %s command" cmd);
457             (match cmd with  (* command from grandchild *)
458             | "test" ->
459                 stop_http_daemon ();
460                 output_string res_pipe "UWOBOmaster: Hello, world!\n";
461                 flush res_pipe;
462                 raise Restart_HTTP_daemon
463             | line when Pcre.pmatch ~rex:kill_cmd_RE line -> (* /kill *)
464                 exit 0
465             | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *)
466                 let bindings =
467                   Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line)
468                 in
469                 stop_http_daemon ();
470                 let logger = new Uwobo_logger.processingLogger () in
471                 List.iter
472                   (fun binding -> (* add a <key, stylesheet> binding *)
473                     let pieces = Pcre.split ~pat:"," binding in
474                     match pieces with
475                     | [key; style] ->
476                         logger#log (sprintf "adding binding <%s,%s>" key style);
477                         veillogger#clearMsgs;
478                         (try
479                           veillogger#clearMsgs;
480                           styles#add key style;
481                           log_libxslt_msgs logger veillogger;
482                         with e ->
483                           logger#log (Printexc.to_string e))
484                     | _ -> logger#log (sprintf "invalid binding %s" binding))
485                   bindings;
486                 output_string res_pipe logger#asHtml;
487                 flush res_pipe;
488                 raise Restart_HTTP_daemon
489             | line when Pcre.pmatch ~rex:remove_cmd_RE line ->  (* /remove *)
490                 stop_http_daemon ();
491                 let arg = Pcre.replace ~rex:remove_cmd_RE line in
492                 let logger = new Uwobo_logger.processingLogger () in
493                 veillogger#clearMsgs;
494                 act_on_keys
495                   arg styles logger
496                   styles#remove (fun () -> styles#removeAll) styles#keys
497                   "removing";
498                 log_libxslt_msgs logger veillogger;
499                 output_string res_pipe (logger#asHtml);
500                 raise Restart_HTTP_daemon
501             | line when Pcre.pmatch ~rex:reload_cmd_RE line ->  (* /reload *)
502                 stop_http_daemon ();
503                 let arg = Pcre.replace ~rex:reload_cmd_RE line in
504                 let logger = new Uwobo_logger.processingLogger () in
505                 veillogger#clearMsgs;
506                 act_on_keys
507                   arg styles logger
508                   styles#reload (fun () -> styles#reloadAll) styles#keys
509                   "reloading";
510                 output_string res_pipe (logger#asHtml);
511                 raise Restart_HTTP_daemon
512             | cmd ->  (* invalid interprocess command received *)
513                 syslogger#log `Warning
514                   (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
515           done
516         with Restart_HTTP_daemon ->
517           close_in cmd_pipe;  (* these calls close also fds *)
518           close_out res_pipe;)
519     | 0 ->  (* (5) child: serve http requests *)
520         Unix.close cmd_pipe_exit;
521         Unix.close res_pipe_entrance;
522         last_process := false;
523         let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in
524         let res_pipe = Unix.in_channel_of_descr res_pipe_exit in
525         debug_print (sprintf "Starting HTTP daemon on port %d ..." port);
526           (* next invocation doesn't return, process will keep on serving HTTP
527           requests until it will get killed by father *)
528         Http_daemon.start'~port ~mode:`Fork
529           (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
530     | _ (* < 0 *) ->  (* fork failed :-((( *)
531         failwith "Can't fork :-("
532   done
533 ;;
534
535   (* daemon initialization *)
536 try
537   Sys.catch_break true;
538   main ()
539 with Sys.Break -> ()  (* 'die_nice' registered with at_exit *)
540 ;;
541