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 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 styles outchan per_key_action all_keys_action logmsg =
 132     let log = new Uwobo_logger.processingLogger () in
 133     let keys =
 134       try
 135         Pcre.split ~pat:"," (req#param "keys")
 136       with Http_types.Param_not_found _ -> []
 137     in
 138     (match keys with
 139     | [] -> (* no key provided, act on all stylesheets *)
 140         log#log "reloading all stylesheets ...";
 141         (try all_keys_action () with e -> log#log (Printexc.to_string e))
 142     | keys ->
 143         List.iter
 144           (fun key -> (* act on a single stylesheet *)
 145             log#log (sprintf "%s stylesheet %s" logmsg key);
 146             (try per_key_action key with e -> log#log (Printexc.to_string e)))
 147           keys);
 148     Http_daemon.respond ~body:log#asHtml outchan
 149   in
 150   let parse_apply_params =  (* parse parameters for '/apply' action *)
 151     let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
 152     let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
 153     let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
 154     List.fold_left
 155       (fun (old_params, old_properties) (name, value) ->
 156         match name with
 157         | name when is_global_param name ->
 158             let name = Pcre.replace ~pat:"^param\\." name in
 159             ((fun x -> (old_params x) @ [name, value]), old_properties)
 160         | name when is_local_param name ->
 161             let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
 162             let (key, name) = (pieces.(1), pieces.(2)) in
 163             ((function
 164               | x when x = key -> [name, value] @ (old_params x)
 165               | x -> old_params x),
 166              old_properties)
 167         | name when is_property name ->
 168             let name = Pcre.replace ~pat:"^prop\\." name in
 169             (old_params, ((name, value) :: old_properties))
 170         | _ -> (old_params, old_properties))
 171       ((fun _ -> []), []) (* no parameters, no properties *)
 172   in
 173   try
 174     syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
 175     syslogger#log `Debug (sprintf "Received request: %s" req#path);
 176     (match req#path with
 177     | "/add" ->
 178         (let bindings = req#paramAll "bind" in
 179         if bindings = [] then
 180           return_error "No [key,stylesheet] binding provided" outchan
 181         else begin
 182           let log = new Uwobo_logger.processingLogger () in
 183           List.iter
 184             (fun binding -> (* add a <key, stylesheet> binding *)
 185               let pieces = Pcre.split ~pat:"," binding in
 186               match pieces with
 187               | [key; style] ->
 188                   log#log (sprintf "adding binding <%s,%s>" key style);
 189                   (try
 190                     styles#add key style;
 191                   with e ->
 192                     log#log (Printexc.to_string e))
 193               | _ -> log#log (sprintf "invalid binding %s" binding))
 194             bindings;
 195           Http_daemon.respond ~body:log#asHtml outchan
 196         end)
 197     | "/list" ->
 198         (let log = new Uwobo_logger.processingLogger () in
 199         log#log "Stylesheet list:";
 200         List.iter (fun s -> log#log s) styles#list;
 201         Http_daemon.respond ~body:log#asHtml outchan)
 202     | "/remove" ->
 203         act_on_keys
 204           req styles outchan
 205           styles#remove (fun () -> styles#removeAll) "removing"
 206     | "/reload" ->
 207         act_on_keys
 208           req styles outchan
 209           styles#reload (fun () -> styles#reloadAll) "reloading"
 210     | "/apply" ->
 211         if Unix.fork () = 0 then
 212           (let logger = new Uwobo_logger.processingLogger () in
 213           let xmluri = req#param "xmluri" in
 214           let keys = Pcre.split ~pat:"," (req#param "keys") in
 215           (* notation: "local" parameters are those defined on a per-stylesheet
 216           pasis (i.e. param.key.param=value), "global" parameters are those
 217           defined for all stylesheets (i.e. param.param=value) *)
 218           let (params, props) = parse_apply_params req#params in
 219           syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
 220           let domImpl = Gdome.domImplementation () in
 221           let input = domImpl#createDocumentFromURI ~uri:xmluri () in
 222           syslogger#log `Debug "Applying stylesheet chain ...";
 223           try
 224             let (write_result, media_type, encoding) = (* out_channel -> unit *)
 225               Uwobo_engine.apply
 226                 ~logger:syslogger ~styles ~keys ~input ~params ~props
 227             in
 228             let content_type = (* value of Content-Type HTTP response header *)
 229               sprintf
 230                 "%s; charset=%s"
 231                 (match media_type with None -> default_media_type | Some t -> t)
 232                 (match encoding with None -> default_encoding | Some e -> e)
 233             in
 234             syslogger#log
 235               `Debug
 236               (sprintf
 237                 "sending output to client (Content-Type: %s)...."
 238                 content_type);
 239             Http_daemon.send_basic_headers ~code:200 outchan;
 240             Http_daemon.send_header "Content-Type" content_type outchan;
 241             Http_daemon.send_CRLF outchan;
 242             write_result outchan
 243           with Uwobo_failure errmsg ->
 244             return_error
 245               (sprintf "Stylesheet chain application failed: %s" errmsg)
 246               outchan)
 247     | "/help" -> Http_daemon.respond ~body:usage_string outchan
 248     | invalid_request ->
 249         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
 250   with
 251   | Http_types.Param_not_found attr_name ->
 252       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 253   | exc ->
 254       Http_daemon.respond
 255         ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
 256         outchan
 257 in
 258
 259   (* daemon initialization *)
 260 syslogger#log
 261   `Notice
 262   (sprintf "%s started and listening on port %d" daemon_name port);
 263 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
 264 Unix.putenv "http_proxy" "";  (* reset http_proxy to avoid libxslt problems *)
 265 Http_daemon.start' ~port ~mode:`Thread callback;
 266 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
 267