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 quando si prova ad applicare uno stylesheet che non e' stato caricato
  28 viene lasciata passare una eccezione Not_found *)
  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 = false;;
  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 = "Help message: not yet written!!" in (* TODO *)
  71
  72   (* thread action *)
  73 let callback req outchan =
  74     (* perform an 'action' that can be applied to a list of keys or, if no
  75     keys was given, to all keys *)
  76   let act_on_keys req styles outchan per_key_action all_keys_action logmsg =
  77     let log = new Uwobo_logger.processingLogger () in
  78     let keys =
  79       try
  80         Pcre.split ~pat:"," (req#param "keys")
  81       with Http_request.Param_not_found _ -> []
  82     in
  83     (match keys with
  84     | [] -> (* no key provided, act on all stylesheets *)
  85         log#log "reloading all stylesheets ...";
  86         (try all_keys_action () with e -> log#log (Printexc.to_string e))
  87     | keys ->
  88         List.iter
  89           (fun key -> (* act on a single stylesheet *)
  90             log#log (sprintf "%s stylesheet %s" logmsg key);
  91             (try per_key_action key with e -> log#log (Printexc.to_string e)))
  92           keys);
  93     Http_daemon.respond ~body:log#asHtml outchan
  94   in
  95   let parse_apply_params =  (* parse parameters for '/apply' action *)
  96     let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
  97     let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
  98     let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
  99     List.fold_left
 100       (fun (old_params, old_properties) (name, value) ->
 101         match name with
 102         | name when is_global_param name ->
 103             let name = Pcre.replace ~pat:"^param\\." name in
 104             ((fun x -> (old_params x) @ [name, value]), old_properties)
 105         | name when is_local_param name ->
 106             let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
 107             let (key, name) = (pieces.(1), pieces.(2)) in
 108             ((function
 109               | x when x = key -> [name, value] @ (old_params x)
 110               | x -> old_params x),
 111              old_properties)
 112         | name when is_property name ->
 113             let name = Pcre.replace ~pat:"^prop\\." name in
 114             (old_params, ((name, value) :: old_properties))
 115         | _ -> (old_params, old_properties))
 116       ((fun _ -> []), []) (* no parameters, no properties *)
 117   in
 118   try
 119     syslogger#log `Debug (sprintf "Received request: %s" req#path);
 120     (match req#path with
 121     | "/add" ->
 122         (let bindings = req#paramAll "bind" in
 123         if bindings = [] then
 124           return_error "No [key,stylesheet] binding provided" outchan
 125         else begin
 126           let log = new Uwobo_logger.processingLogger () in
 127           List.iter
 128             (fun binding -> (* add a <key, stylesheet> binding *)
 129               let pieces = Pcre.split ~pat:"," binding in
 130               match pieces with
 131               | [key; style] ->
 132                   log#log (sprintf "adding binding <%s,%s>" key style);
 133                   (try
 134                     styles#add key style;
 135                   with e ->
 136                     log#log (Printexc.to_string e))
 137               | _ -> log#log (sprintf "invalid binding %s" binding))
 138             bindings;
 139           Http_daemon.respond ~body:log#asHtml outchan
 140         end)
 141     | "/list" ->
 142         (let log = new Uwobo_logger.processingLogger () in
 143         log#log "Stylesheet list:";
 144         List.iter (fun s -> log#log s) styles#list;
 145         Http_daemon.respond ~body:log#asHtml outchan)
 146     | "/remove" ->
 147         act_on_keys
 148           req styles outchan
 149           styles#remove (fun () -> styles#removeAll) "removing"
 150     | "/reload" ->
 151         act_on_keys
 152           req styles outchan
 153           styles#reload (fun () -> styles#reloadAll) "reloading"
 154     | "/apply" ->
 155         if Unix.fork () = 0 then
 156           (let logger = new Uwobo_logger.processingLogger () in
 157           let xmluri = req#param "xmluri" in
 158           let keys = Pcre.split ~pat:"," (req#param "keys") in
 159           (* notation: "local" parameters are those defined on a per-stylesheet
 160           pasis (i.e. param.key.param=value), "global" parameters are those
 161           defined for all stylesheets (i.e. param.param=value) *)
 162           let (params, props) = parse_apply_params req#params in
 163           syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
 164           let domImpl = Gdome.domImplementation () in
 165           let input = domImpl#createDocumentFromURI ~uri:xmluri () in
 166           syslogger#log `Debug "Applying stylesheet chain ...";
 167           try
 168             let (write_result, media_type, encoding) = (* out_channel -> unit *)
 169               Uwobo_engine.apply
 170                 ~logger:syslogger ~styles ~keys ~input ~params ~props
 171             in
 172             let content_type = (* value of Content-Type HTTP response header *)
 173               sprintf
 174                 "%s; charset=%s"
 175                 (match media_type with None -> default_media_type | Some t -> t)
 176                 (match encoding with None -> default_encoding | Some e -> e)
 177             in
 178             syslogger#log
 179               `Debug
 180               (sprintf
 181                 "sending output to client (Content-Type: %s)...."
 182                 content_type);
 183             Http_daemon.send_basic_headers ~code:200 outchan;
 184             Http_daemon.send_header "Content-Type" content_type outchan;
 185             Http_daemon.send_CRLF outchan;
 186             write_result outchan
 187           with Uwobo_failure errmsg ->
 188             return_error
 189               (sprintf "Stylesheet chain application failed: %s" errmsg)
 190               outchan)
 191     | "/help" -> Http_daemon.respond ~body:usage_string outchan
 192     | invalid_request ->
 193         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
 194   with
 195   | Http_request.Param_not_found attr_name ->
 196       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 197   | exc ->
 198       Http_daemon.respond
 199         ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
 200         outchan
 201 in
 202
 203   (* daemon initialization *)
 204 syslogger#log
 205   `Notice
 206   (sprintf "%s started and listening on port %d" daemon_name port);
 207 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
 208 Http_daemon.start' ~port ~mode:`Thread callback;
 209 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
 210