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_file = "uwobo.log" ;; (* relative to execution dir *)
  41 let default_port = 58080 ;;
  42 let port_env_var = "UWOBO_PORT" ;;
  43 let default_media_type = "text/html" ;;
  44 let default_encoding = "utf8" ;;
  45 let logfile =
  46   Some (try Sys.getenv "UWOBO_LOG_FILE" with Not_found -> default_log_file)
  47 ;;
  48 let logfile_perm = 0o640 ;;
  49 let port =
  50   try
  51     int_of_string (Sys.getenv port_env_var)
  52   with
  53   | Not_found -> default_port
  54   | Failure "int_of_string" ->
  55       prerr_endline "Warning: invalid port, reverting to default";
  56       default_port
  57 ;;
  58
  59 let respond_html body outchan =
  60   Http_daemon.respond ~body ~headers:["Content-Type", "text/html"] outchan
  61 ;;
  62
  63   (** perform an 'action' that can be applied to a list of keys or, if no keys
  64   was given, to all keys *)
  65 let act_on_keys
  66   keys_param styles logger per_key_action all_keys_action all_keys logmsg
  67 =
  68   let keys =
  69     try
  70       Pcre.split ~pat:"," keys_param
  71     with Http_types.Param_not_found _ -> []
  72   in
  73   match keys with
  74   | [] -> (* no key provided, act on all stylesheets *)
  75       logger#log (sprintf "%s all stylesheets (keys = %s) ..."
  76         logmsg (String.concat ", " all_keys));
  77       (try all_keys_action () with e -> logger#log (Printexc.to_string e));
  78       logger#log (sprintf "Done! (all stylesheets)")
  79   | keys ->
  80       List.iter
  81         (fun key -> (* act on a single stylesheet *)
  82           logger#log (sprintf "%s stylesheet %s" logmsg key);
  83           (try per_key_action key with e -> logger#log (Printexc.to_string e));
  84           logger#log (sprintf "Done! (stylesheet %s)" key))
  85         keys
  86 ;;
  87
  88   (** parse parameters for '/apply' action *)
  89 let parse_apply_params =
  90   let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
  91   let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
  92   let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
  93   List.fold_left
  94     (fun (old_params, old_properties) (name, value) ->
  95       match name with
  96       | name when is_global_param name ->
  97           let name = Pcre.replace ~pat:"^param\\." name in
  98           ((fun x -> (old_params x) @ [name, value]), old_properties)
  99       | name when is_local_param name ->
 100           let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
 101           let (key, name) = (pieces.(1), pieces.(2)) in
 102           ((function
 103             | x when x = key -> [name, value] @ (old_params x)
 104             | x -> old_params x),
 105            old_properties)
 106       | name when is_property name ->
 107           let name = Pcre.replace ~pat:"^prop\\." name in
 108           (old_params, ((name, value) :: old_properties))
 109       | _ -> (old_params, old_properties))
 110     ((fun _ -> []), []) (* no parameters, no properties *)
 111 ;;
 112
 113   (** Parse libxslt's message modes for error and debugging messages. Default is
 114   to ignore mesages of both kind *)
 115 let parse_libxslt_msgs_mode (req: Http_types.request) =
 116   ((try
 117     (match req#param "errormode" with
 118     | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
 119     | s when String.lowercase s = "comment" -> LibXsltMsgComment
 120     | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
 121     | err ->
 122         raise (Uwobo_failure
 123           (sprintf
 124             "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
 125             err "errormode" "ignore" "comment")))
 126   with Http_types.Param_not_found _ -> LibXsltMsgIgnore),
 127   (try
 128     (match req#param "debugmode" with
 129     | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
 130     | s when String.lowercase s = "comment" -> LibXsltMsgComment
 131     | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
 132     | err ->
 133         raise (Uwobo_failure
 134           (sprintf
 135             "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
 136             err "debugmode" "ignore" "comment")))
 137   with Http_types.Param_not_found _ -> LibXsltMsgIgnore))
 138 ;;
 139
 140   (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer
 141   on ~res_pipe (with a timeout of 60 seconds) and send over outchan data
 142   received from ~res_pipe *)
 143 let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
 144 (*   debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); *)
 145   output_string cmd_pipe (cmd ^ "\n");  (* send command to grandfather *)
 146   flush cmd_pipe;
 147   let res_pipe_fd = Unix.descr_of_in_channel res_pipe in
 148   let (read_fds, _, _) =  (* wait for an answer *)
 149     Unix.select [res_pipe_fd] [] [] 60.0
 150   in
 151   (match read_fds with
 152   | [fd] when fd = res_pipe_fd -> (* send answer to http client *)
 153       Http_daemon.send_basic_headers ~code:200 outchan;
 154       Http_daemon.send_header "Content-Type" "text/html" outchan;
 155       Http_daemon.send_CRLF outchan;
 156       (try
 157         while true do
 158           output_string outchan ((input_line res_pipe) ^ "\n")
 159         done
 160       with End_of_file -> flush outchan)
 161   | _ ->  (* no answer received from grandfather *)
 162       return_error "Timeout!" outchan)
 163 ;;
 164
 165 let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE) =
 166   (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ")
 167 ;;
 168
 169   (** raised by child processes when HTTP daemon process have to be restarted *)
 170 exception Restart_HTTP_daemon ;;
 171
 172   (** log a list of libxslt's messages using a processing logger *)
 173 let log_libxslt_msgs logger libxslt_logger =
 174   List.iter
 175     (function
 176       | (LibXsltErrorMsg _) as msg -> logger#logBold (string_of_xslt_msg msg)
 177       | (LibXsltDebugMsg _) as msg -> logger#logEmph (string_of_xslt_msg msg))
 178     libxslt_logger#msgs
 179 ;;
 180
 181   (* LibXSLT logger *)
 182 let veillogger = new Uwobo_common.libXsltLogger ;;
 183
 184   (* request handler action
 185   @param syslogger Uwobo_logger.sysLogger instance used for logginf
 186   @param styles Uwobo_styles.styles instance which keeps the stylesheets list
 187   @param cmd_pipe output _channel_ used to _write_ update messages
 188   @param res_pipe input _channel_ used to _read_ grandparent results
 189   @param req http request instance
 190   @param outchan output channel connected to http client
 191   *)
 192 let callback
 193   ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
 194   =
 195   try
 196     syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
 197     syslogger#log `Debug (sprintf "Received request: %s" req#path);
 198     (match req#path with
 199     | "/add" ->
 200         (let bindings = req#paramAll "bind" in
 201         if bindings = [] then
 202           return_error "No [key,stylesheet] binding provided" outchan
 203         else begin
 204           let cmd = sprintf "add %s" (String.concat ";" bindings) in
 205           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 206         end)
 207     | "/remove" ->
 208           let cmd = sprintf "remove %s" (req#param "keys") in
 209           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 210     | "/reload" ->
 211           let cmd = sprintf "reload %s" (req#param "keys") in
 212           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 213     | "/list" ->
 214         (let logger = new Uwobo_logger.processingLogger () in
 215         (match styles#list with
 216         | [] -> logger#log "No stylesheets loaded (yet)!"
 217         | l ->
 218             logger#log "Stylesheets list:";
 219             List.iter (fun s -> logger#log s) l);
 220         respond_html logger#asHtml outchan)
 221     | "/apply" ->
 222         let logger = new Uwobo_logger.processingLogger () in
 223         veillogger#clearMsgs;
 224         let xmluri = req#param "xmluri" in
 225         let keys = Pcre.split ~pat:"," (req#param "keys") in
 226         (* notation: "local" parameters are those defined on a per-stylesheet
 227         pasis (i.e. param.key.param=value), "global" parameters are those
 228         defined for all stylesheets (i.e. param.param=value) *)
 229         let (params, props) = parse_apply_params req#params in
 230         let (libxslt_errormode, libxslt_debugmode) =
 231           parse_libxslt_msgs_mode req
 232         in
 233         syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
 234         let domImpl = Gdome.domImplementation () in
 235         let input = domImpl#createDocumentFromURI ~uri:xmluri () in
 236         syslogger#log `Debug "Applying stylesheet chain ...";
 237         (try
 238           let (write_result, media_type, encoding) = (* out_channel -> unit *)
 239             Uwobo_engine.apply
 240               ~logger:syslogger ~styles ~keys ~params ~props ~veillogger
 241               ~errormode:libxslt_errormode ~debugmode:libxslt_debugmode
 242               input
 243           in
 244           let content_type = (* value of Content-Type HTTP response header *)
 245             sprintf "%s; charset=%s"
 246               (match media_type with None -> default_media_type | Some t -> t)
 247               (match encoding with None -> default_encoding | Some e -> e)
 248           in
 249           syslogger#log `Debug
 250             (sprintf "sending output to client (Content-Type: %s)...."
 251               content_type);
 252           Http_daemon.send_basic_headers ~code:200 outchan;
 253           Http_daemon.send_header "Content-Type" content_type outchan;
 254           Http_daemon.send_CRLF outchan;
 255           write_result outchan
 256         with Uwobo_failure errmsg ->
 257           return_error
 258             ("Stylesheet chain application failed: " ^ errmsg)
 259             ~body: ("<h2>LibXSLT's messages:</h2>" ^
 260               String.concat "<br />\n"
 261                 (List.map string_of_xslt_msg veillogger#msgs))
 262             outchan)
 263     | "/help" -> respond_html usage_string outchan
 264     | invalid_request ->
 265         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
 266     syslogger#log `Debug (sprintf "%s done!" req#path);
 267   with
 268   | Http_types.Param_not_found attr_name ->
 269       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 270   | exc ->
 271       return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
 272 ;;
 273
 274   (* UWOBO's startup *)
 275 let main () =
 276     (* (1) system logger *)
 277   let logger_outchan =
 278     match logfile with
 279     | None ->
 280         debug_print "Logging to standard error";
 281         stderr
 282     | Some f ->
 283         debug_print (sprintf "Logging to file %s" f);
 284         open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm f
 285   in
 286   let syslogger =
 287     new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
 288   in
 289   syslogger#enable;
 290     (* (2) stylesheets list *)
 291   let styles = new Uwobo_styles.styles in
 292     (* (3) clean up actions *)
 293   let last_process = ref true in
 294   let http_child = ref None in
 295   let die_nice () = (** at_exit callback *)
 296     if !last_process then begin
 297       (match !http_child with
 298       | None -> ()
 299       | Some pid -> Unix.kill pid Sys.sigterm);
 300       syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
 301       syslogger#disable;
 302       close_out logger_outchan
 303     end
 304   in
 305   at_exit die_nice;
 306   ignore (Sys.signal Sys.sigterm
 307     (Sys.Signal_handle (fun _ -> raise Sys.Break)));
 308   syslogger#log `Notice
 309     (sprintf "%s started and listening on port %d" daemon_name port);
 310   syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
 311   Unix.putenv "http_proxy" "";  (* reset http_proxy to avoid libxslt problems *)
 312   while true do
 313     let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
 314     let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
 315     match Unix.fork () with
 316     | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *)
 317         http_child := Some child;
 318         let stop_http_daemon () =  (* kill child *)
 319           debug_print (sprintf "UWOBOmaster: killing pid %d" child);
 320           Unix.kill child Sys.sigterm;  (* kill child ... *)
 321           ignore (Unix.waitpid [] child);  (* ... and its zombie *)
 322         in
 323         Unix.close cmd_pipe_entrance;
 324         Unix.close res_pipe_exit;
 325         let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
 326         let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
 327         (try
 328           while true do
 329             (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
 330             child process has been killed *)
 331             debug_print "UWOBOmaster: waiting for commands ...";
 332             let cmd = input_line cmd_pipe in
 333             debug_print (sprintf "UWOBOmaster: received %s command" cmd);
 334             (match cmd with  (* command from grandchild *)
 335             | "test" ->
 336                 stop_http_daemon ();
 337                 output_string res_pipe "UWOBOmaster: Hello, world!\n";
 338                 flush res_pipe;
 339                 raise Restart_HTTP_daemon
 340             | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *)
 341                 let bindings =
 342                   Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line)
 343                 in
 344                 stop_http_daemon ();
 345                 let logger = new Uwobo_logger.processingLogger () in
 346                 List.iter
 347                   (fun binding -> (* add a <key, stylesheet> binding *)
 348                     let pieces = Pcre.split ~pat:"," binding in
 349                     match pieces with
 350                     | [key; style] ->
 351                         logger#log (sprintf "adding binding <%s,%s>" key style);
 352                         veillogger#clearMsgs;
 353                         (try
 354                           veillogger#clearMsgs;
 355                           styles#add key style;
 356                           log_libxslt_msgs logger veillogger;
 357                         with e ->
 358                           logger#log (Printexc.to_string e))
 359                     | _ -> logger#log (sprintf "invalid binding %s" binding))
 360                   bindings;
 361                 output_string res_pipe logger#asHtml;
 362                 flush res_pipe;
 363                 raise Restart_HTTP_daemon
 364             | line when Pcre.pmatch ~rex:remove_cmd_RE line ->  (* /remove *)
 365                 stop_http_daemon ();
 366                 let arg = Pcre.replace ~rex:remove_cmd_RE line in
 367                 let logger = new Uwobo_logger.processingLogger () in
 368                 veillogger#clearMsgs;
 369                 act_on_keys
 370                   arg styles logger
 371                   styles#remove (fun () -> styles#removeAll) styles#keys
 372                   "removing";
 373                 log_libxslt_msgs logger veillogger;
 374                 output_string res_pipe (logger#asHtml);
 375                 raise Restart_HTTP_daemon
 376             | line when Pcre.pmatch ~rex:reload_cmd_RE line ->  (* /reload *)
 377                 stop_http_daemon ();
 378                 let arg = Pcre.replace ~rex:reload_cmd_RE line in
 379                 let logger = new Uwobo_logger.processingLogger () in
 380                 veillogger#clearMsgs;
 381                 act_on_keys
 382                   arg styles logger
 383                   styles#reload (fun () -> styles#reloadAll) styles#keys
 384                   "reloading";
 385                 output_string res_pipe (logger#asHtml);
 386                 raise Restart_HTTP_daemon
 387             | cmd ->  (* invalid interprocess command received *)
 388                 syslogger#log `Warning
 389                   (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
 390           done
 391         with Restart_HTTP_daemon ->
 392           close_in cmd_pipe;  (* these calls close also fds *)
 393           close_out res_pipe;)
 394     | 0 ->  (* (5) child: serve http requests *)
 395         Unix.close cmd_pipe_exit;
 396         Unix.close res_pipe_entrance;
 397         last_process := false;
 398         let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in
 399         let res_pipe = Unix.in_channel_of_descr res_pipe_exit in
 400         debug_print (sprintf "Starting HTTP daemon on port %d ..." port);
 401           (* next invocation doesn't return, process will keep on serving HTTP
 402           requests until it will get killed by father *)
 403         Http_daemon.start'~port ~mode:`Fork
 404           (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
 405     | _ (* < 0 *) ->  (* fork failed :-((( *)
 406         failwith "Can't fork :-("
 407   done
 408 ;;
 409
 410   (* daemon initialization *)
 411 try
 412   Sys.catch_break true;
 413   main ()
 414 with Sys.Break -> ()  (* 'die_nice' registered with at_exit *)
 415 ;;
 416