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