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 braindead situation: /add of a stylesheet which uri is an uwobo
  28 invocation *)
  29
  30 open Printf;;
  31 open Uwobo_common;;
  32
  33  (* debugging settings *)
  34 let debug = true;;
  35 let debug_level = `Debug;;
  36 let debug_print s = if debug then prerr_endline s;;
  37 let http_debug = true;;
  38 Http_common.debug := http_debug;;
  39
  40   (* environment settings *)
  41 let daemon_name = "UWOBO OCaml";;
  42 let default_port = 8082;;
  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 in
  55
  56   (* facilities *)
  57 let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" in
  58 let return_error msg outchan =
  59   (* return an ok (200) http response, which display in html an error message *)
  60   Http_daemon.respond ~body:(pp_error msg) outchan
  61 in
  62 let bad_request body outchan =  (* return a bad request http response *)
  63   Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
  64 in
  65
  66   (* values common to all threads *)
  67 let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
  68 syslogger#enable;
  69 let styles = new Uwobo_styles.styles in
  70 let usage_string =
  71   sprintf
  72 "
  73 <html>
  74   <head>
  75     <title>UWOBO's help message</title>
  76   </head>
  77   <body>
  78     <p>
  79     Usage: <kbd>http://hostname:uwoboport/</kbd><em>command</em>
  80     </p>
  81     <p>
  82     Available commands:
  83     </p>
  84     <p>
  85       <b><kbd>help</kbd></b><br />
  86       display this help message
  87     </p>
  88     <p>
  89       <b><kbd>add?bind=key,uri[&bind=key,stylesheet[&...]]</kbd></b><br />
  90       load a new stylesheet, specified by <em>uri</em>, and bind it to key
  91           <em>key</em>
  92     </p>
  93     <p>
  94       <b><kbd>remove?[?keys=key1,key2,...]</kbd></b><br />
  95       unload stylesheets specified by <em>key1, key2, ...</em> or all
  96           stylesheets if no key was given
  97     </p>
  98     <p>
  99       <b><kbd>reload?[?keys=key1,key2,...]</kbd></b><br />
 100       reload stylesheets specified by <em>key1, key2, ...</em> or all
 101           stylesheets if no key was given
 102     </p>
 103     <p>
 104       <b><kbd>list</kbd></b><br />
 105       return a list of loaded stylesheets
 106     </p>
 107     <p>
 108       <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 />
 109       apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
 110       input document, specified by <em>uri</em>.<br />
 111       Additional parameters can be set for each stylesheet application: global
 112       parameters (i.e. parameters passed to all stylesheets) are set using
 113       <em>param.name=value</em> syntax, per stylesheet parameters are set using
 114       <em>param.key.name=value</em> where <em>key</em> is the key of a loaded
 115       stylesheet.<br />
 116       Properties of the final chain output can be set too: valueless properties
 117       can be set using <em>prop.name</em> syntax, others can be set using
 118       <em>prop.name=value</em> syntax.<br />
 119       Current supported properties are: %s.
 120     </p>
 121   </body>
 122 </html>
 123 "
 124   (String.concat ", " Uwobo_common.supported_properties)
 125 in
 126
 127   (* thread action *)
 128 let callback (req: Http_types.request) outchan =
 129     (* perform an 'action' that can be applied to a list of keys or, if no
 130     keys was given, to all keys *)
 131   let act_on_keys (req: Http_types.request)
 132     styles outchan per_key_action all_keys_action logmsg
 133     =
 134     let log = new Uwobo_logger.processingLogger () in
 135     let keys =
 136       try
 137         Pcre.split ~pat:"," (req#param "keys")
 138       with Http_types.Param_not_found _ -> []
 139     in
 140     (match keys with
 141     | [] -> (* no key provided, act on all stylesheets *)
 142         log#log "reloading all stylesheets ...";
 143         (try all_keys_action () with e -> log#log (Printexc.to_string e))
 144     | keys ->
 145         List.iter
 146           (fun key -> (* act on a single stylesheet *)
 147             log#log (sprintf "%s stylesheet %s" logmsg key);
 148             (try per_key_action key with e -> log#log (Printexc.to_string e)))
 149           keys);
 150     Http_daemon.respond ~body:log#asHtml outchan
 151   in
 152   let parse_apply_params =  (* parse parameters for '/apply' action *)
 153     let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
 154     let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
 155     let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
 156     List.fold_left
 157       (fun (old_params, old_properties) (name, value) ->
 158         match name with
 159         | name when is_global_param name ->
 160             let name = Pcre.replace ~pat:"^param\\." name in
 161             ((fun x -> (old_params x) @ [name, value]), old_properties)
 162         | name when is_local_param name ->
 163             let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
 164             let (key, name) = (pieces.(1), pieces.(2)) in
 165             ((function
 166               | x when x = key -> [name, value] @ (old_params x)
 167               | x -> old_params x),
 168              old_properties)
 169         | name when is_property name ->
 170             let name = Pcre.replace ~pat:"^prop\\." name in
 171             (old_params, ((name, value) :: old_properties))
 172         | _ -> (old_params, old_properties))
 173       ((fun _ -> []), []) (* no parameters, no properties *)
 174   in
 175   try
 176     syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
 177     syslogger#log `Debug (sprintf "Received request: %s" req#path);
 178     (match req#path with
 179     | "/add" ->
 180         (let bindings = req#paramAll "bind" in
 181         if bindings = [] then
 182           return_error "No [key,stylesheet] binding provided" outchan
 183         else begin
 184           let log = new Uwobo_logger.processingLogger () in
 185           List.iter
 186             (fun binding -> (* add a <key, stylesheet> binding *)
 187               let pieces = Pcre.split ~pat:"," binding in
 188               match pieces with
 189               | [key; style] ->
 190                   log#log (sprintf "adding binding <%s,%s>" key style);
 191                   (try
 192                     styles#add key style;
 193                   with e ->
 194                     log#log (Printexc.to_string e))
 195               | _ -> log#log (sprintf "invalid binding %s" binding))
 196             bindings;
 197           Http_daemon.respond ~body:log#asHtml outchan
 198         end)
 199     | "/list" ->
 200         (let log = new Uwobo_logger.processingLogger () in
 201         log#log "Stylesheet list:";
 202         List.iter (fun s -> log#log s) styles#list;
 203         Http_daemon.respond ~body:log#asHtml outchan)
 204     | "/remove" ->
 205         act_on_keys
 206           req styles outchan
 207           styles#remove (fun () -> styles#removeAll) "removing"
 208     | "/reload" ->
 209         act_on_keys
 210           req styles outchan
 211           styles#reload (fun () -> styles#reloadAll) "reloading"
 212     | "/apply" ->
 213         if Unix.fork () = 0 then
 214           (let logger = new Uwobo_logger.processingLogger () in
 215           let xmluri = req#param "xmluri" in
 216           let keys = Pcre.split ~pat:"," (req#param "keys") in
 217           (* notation: "local" parameters are those defined on a per-stylesheet
 218           pasis (i.e. param.key.param=value), "global" parameters are those
 219           defined for all stylesheets (i.e. param.param=value) *)
 220           let (params, props) = parse_apply_params req#params in
 221           syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
 222           let domImpl = Gdome.domImplementation () in
 223           let input = domImpl#createDocumentFromURI ~uri:xmluri () in
 224           syslogger#log `Debug "Applying stylesheet chain ...";
 225           try
 226             let (write_result, media_type, encoding) = (* out_channel -> unit *)
 227               Uwobo_engine.apply
 228                 ~logger:syslogger ~styles ~keys ~input ~params ~props
 229             in
 230             let content_type = (* value of Content-Type HTTP response header *)
 231               sprintf
 232                 "%s; charset=%s"
 233                 (match media_type with None -> default_media_type | Some t -> t)
 234                 (match encoding with None -> default_encoding | Some e -> e)
 235             in
 236             syslogger#log
 237               `Debug
 238               (sprintf
 239                 "sending output to client (Content-Type: %s)...."
 240                 content_type);
 241             Http_daemon.send_basic_headers ~code:200 outchan;
 242             Http_daemon.send_header "Content-Type" content_type outchan;
 243             Http_daemon.send_CRLF outchan;
 244             write_result outchan
 245           with Uwobo_failure errmsg ->
 246             return_error
 247               (sprintf "Stylesheet chain application failed: %s" errmsg)
 248               outchan)
 249     | "/help" -> Http_daemon.respond ~body:usage_string outchan
 250     | invalid_request ->
 251         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
 252   with
 253   | Http_types.Param_not_found attr_name ->
 254       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 255   | exc ->
 256       Http_daemon.respond
 257         ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
 258         outchan
 259 in
 260
 261   (* daemon initialization *)
 262 syslogger#log
 263   `Notice
 264   (sprintf "%s started and listening on port %d" daemon_name port);
 265 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
 266 Unix.putenv "http_proxy" "";  (* reset http_proxy to avoid libxslt problems *)
 267 Http_daemon.start' ~port ~mode:`Thread callback;
 268 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
 269