helm/uwobo/src/ocaml/uwobo.ml

   1
   2 (* Copyright (C) 2002, HELM Team.
   3  *
   4  * This file is part of HELM, an Hypertextual, Electronic
   5  * Library of Mathematics, developed at the Computer Science
   6  * Department, University of Bologna, Italy.
   7  *
   8  * HELM is free software; you can redistribute it and/or
   9  * modify it under the terms of the GNU General Public License
  10  * as published by the Free Software Foundation; either version 2
  11  * of the License, or (at your option) any later version.
  12  *
  13  * HELM is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  * GNU General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU General Public License
  19  * along with HELM; if not, write to the Free Software
  20  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21  * MA  02111-1307, USA.
  22  *
  23  * For details, see the HELM World-Wide-Web page,
  24  * http://cs.unibo.it/helm/.
  25  *)
  26
  27 (* TODO libxslt support 'http_proxy' variables, but IIRC access to this
  28 variables is mentioned in non-reentrant stuff, so having those variables set
  29 cause uwobo not to work properly when invoked recursively *)
  30
  31 (* TODO braindead situation: /add of a stylesheet which uri is an uwobo
  32 invocation *)
  33
  34 open Printf;;
  35 open Uwobo_common;;
  36
  37  (* debugging settings *)
  38 let debug = true;;
  39 let debug_level = `Debug;;
  40 let debug_print s = if debug then prerr_endline s;;
  41 let http_debug = false;;
  42 Http_common.debug := http_debug;;
  43
  44   (* environment settings *)
  45 let daemon_name = "UWOBO OCaml";;
  46 let default_port = 8082;;
  47 let port_env_var = "UWOBO_PORT";;
  48 let default_media_type = "text/html";;
  49 let default_encoding = "utf8";;
  50 let port =
  51   try
  52     int_of_string (Sys.getenv port_env_var)
  53   with
  54   | Not_found -> default_port
  55   | Failure "int_of_string" ->
  56       prerr_endline "Warning: invalid port, reverting to default";
  57       default_port
  58 in
  59
  60   (* facilities *)
  61 let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" in
  62 let return_error msg outchan =
  63   (* return an ok (200) http response, which display in html an error message *)
  64   Http_daemon.respond ~body:(pp_error msg) outchan
  65 in
  66 let bad_request body outchan =  (* return a bad request http response *)
  67   Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
  68 in
  69
  70   (* values common to all threads *)
  71 let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
  72 syslogger#enable;
  73 let styles = new Uwobo_styles.styles in
  74 let usage_string =
  75   sprintf
  76 "
  77 <html>
  78   <head>
  79     <title>UWOBO's help message</title>
  80   </head>
  81   <body>
  82     <p>
  83     Usage: <kbd>http://hostname:uwoboport/</kbd><em>command</em>
  84     </p>
  85     <p>
  86     Available commands:
  87     </p>
  88     <p>
  89       <b><kbd>help</kbd></b><br />
  90       display this help message
  91     </p>
  92     <p>
  93       <b><kbd>add?bind=key,uri[&bind=key,stylesheet[&...]]</kbd></b><br />
  94       load a new stylesheet, specified by <em>uri</em>, and bind it to key
  95           <em>key</em>
  96     </p>
  97     <p>
  98       <b><kbd>remove?[?keys=key1,key2,...]</kbd></b><br />
  99       unload stylesheets specified by <em>key1, key2, ...</em> or all
 100           stylesheets if no key was given
 101     </p>
 102     <p>
 103       <b><kbd>reload?[?keys=key1,key2,...]</kbd></b><br />
 104       reload stylesheets specified by <em>key1, key2, ...</em> or all
 105           stylesheets if no key was given
 106     </p>
 107     <p>
 108       <b><kbd>list</kbd></b><br />
 109       return a list of loaded stylesheets
 110     </p>
 111     <p>
 112       <b><kbd>apply?xmluri=uri&keys=key1,key2,...[&param.name=value[&param.name=value[&...]]][&param.key.name=value[&param.key.name=value[&...]]][&name[=value][&prop.name[=value][&...]]]</kbd></b><br />
 113       apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
 114       input document, specified by <em>uri</em>.<br />
 115       Additional parameters can be set for each stylesheet application: global
 116       parameters (i.e. parameters passed to all stylesheets) are set using
 117       <em>param.name=value</em> syntax, per stylesheet parameters are set using
 118       <em>param.key.name=value</em> where <em>key</em> is the key of a loaded
 119       stylesheet.<br />
 120       Properties of the final chain output can be set too: valueless properties
 121       can be set using <em>prop.name</em> syntax, others can be set using
 122       <em>prop.name=value</em> syntax.<br />
 123       Current supported properties are: %s.
 124     </p>
 125   </body>
 126 </html>
 127 "
 128   (String.concat ", " Uwobo_common.supported_properties)
 129 in
 130
 131   (* thread action *)
 132 let callback req outchan =
 133     (* perform an 'action' that can be applied to a list of keys or, if no
 134     keys was given, to all keys *)
 135   let act_on_keys req styles outchan per_key_action all_keys_action logmsg =
 136     let log = new Uwobo_logger.processingLogger () in
 137     let keys =
 138       try
 139         Pcre.split ~pat:"," (req#param "keys")
 140       with Http_request.Param_not_found _ -> []
 141     in
 142     (match keys with
 143     | [] -> (* no key provided, act on all stylesheets *)
 144         log#log "reloading all stylesheets ...";
 145         (try all_keys_action () with e -> log#log (Printexc.to_string e))
 146     | keys ->
 147         List.iter
 148           (fun key -> (* act on a single stylesheet *)
 149             log#log (sprintf "%s stylesheet %s" logmsg key);
 150             (try per_key_action key with e -> log#log (Printexc.to_string e)))
 151           keys);
 152     Http_daemon.respond ~body:log#asHtml outchan
 153   in
 154   let parse_apply_params =  (* parse parameters for '/apply' action *)
 155     let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
 156     let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
 157     let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
 158     List.fold_left
 159       (fun (old_params, old_properties) (name, value) ->
 160         match name with
 161         | name when is_global_param name ->
 162             let name = Pcre.replace ~pat:"^param\\." name in
 163             ((fun x -> (old_params x) @ [name, value]), old_properties)
 164         | name when is_local_param name ->
 165             let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
 166             let (key, name) = (pieces.(1), pieces.(2)) in
 167             ((function
 168               | x when x = key -> [name, value] @ (old_params x)
 169               | x -> old_params x),
 170              old_properties)
 171         | name when is_property name ->
 172             let name = Pcre.replace ~pat:"^prop\\." name in
 173             (old_params, ((name, value) :: old_properties))
 174         | _ -> (old_params, old_properties))
 175       ((fun _ -> []), []) (* no parameters, no properties *)
 176   in
 177   try
 178     syslogger#log `Debug (sprintf "Received request: %s" req#path);
 179     (match req#path with
 180     | "/add" ->
 181         (let bindings = req#paramAll "bind" in
 182         if bindings = [] then
 183           return_error "No [key,stylesheet] binding provided" outchan
 184         else begin
 185           let log = new Uwobo_logger.processingLogger () in
 186           List.iter
 187             (fun binding -> (* add a <key, stylesheet> binding *)
 188               let pieces = Pcre.split ~pat:"," binding in
 189               match pieces with
 190               | [key; style] ->
 191                   log#log (sprintf "adding binding <%s,%s>" key style);
 192                   (try
 193                     styles#add key style;
 194                   with e ->
 195                     log#log (Printexc.to_string e))
 196               | _ -> log#log (sprintf "invalid binding %s" binding))
 197             bindings;
 198           Http_daemon.respond ~body:log#asHtml outchan
 199         end)
 200     | "/list" ->
 201         (let log = new Uwobo_logger.processingLogger () in
 202         log#log "Stylesheet list:";
 203         List.iter (fun s -> log#log s) styles#list;
 204         Http_daemon.respond ~body:log#asHtml outchan)
 205     | "/remove" ->
 206         act_on_keys
 207           req styles outchan
 208           styles#remove (fun () -> styles#removeAll) "removing"
 209     | "/reload" ->
 210         act_on_keys
 211           req styles outchan
 212           styles#reload (fun () -> styles#reloadAll) "reloading"
 213     | "/apply" ->
 214         if Unix.fork () = 0 then
 215           (let logger = new Uwobo_logger.processingLogger () in
 216           let xmluri = req#param "xmluri" in
 217           let keys = Pcre.split ~pat:"," (req#param "keys") in
 218           (* notation: "local" parameters are those defined on a per-stylesheet
 219           pasis (i.e. param.key.param=value), "global" parameters are those
 220           defined for all stylesheets (i.e. param.param=value) *)
 221           let (params, props) = parse_apply_params req#params in
 222           syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
 223           let domImpl = Gdome.domImplementation () in
 224           let input = domImpl#createDocumentFromURI ~uri:xmluri () in
 225           syslogger#log `Debug "Applying stylesheet chain ...";
 226           try
 227             let (write_result, media_type, encoding) = (* out_channel -> unit *)
 228               Uwobo_engine.apply
 229                 ~logger:syslogger ~styles ~keys ~input ~params ~props
 230             in
 231             let content_type = (* value of Content-Type HTTP response header *)
 232               sprintf
 233                 "%s; charset=%s"
 234                 (match media_type with None -> default_media_type | Some t -> t)
 235                 (match encoding with None -> default_encoding | Some e -> e)
 236             in
 237             syslogger#log
 238               `Debug
 239               (sprintf
 240                 "sending output to client (Content-Type: %s)...."
 241                 content_type);
 242             Http_daemon.send_basic_headers ~code:200 outchan;
 243             Http_daemon.send_header "Content-Type" content_type outchan;
 244             Http_daemon.send_CRLF outchan;
 245             write_result outchan
 246           with Uwobo_failure errmsg ->
 247             return_error
 248               (sprintf "Stylesheet chain application failed: %s" errmsg)
 249               outchan)
 250     | "/help" -> Http_daemon.respond ~body:usage_string outchan
 251     | invalid_request ->
 252         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
 253   with
 254   | Http_request.Param_not_found attr_name ->
 255       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 256   | exc ->
 257       Http_daemon.respond
 258         ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
 259         outchan
 260 in
 261
 262   (* daemon initialization *)
 263 syslogger#log
 264   `Notice
 265   (sprintf "%s started and listening on port %d" daemon_name port);
 266 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
 267 Http_daemon.start' ~port ~mode:`Thread callback;
 268 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
 269