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 open Printf;;
  28 open Uwobo_common;;
  29
  30  (* debugging settings *)
  31 let debug = true;;
  32 let debug_level = `Debug;;
  33 let debug_print s = if debug then prerr_endline s;;
  34 let http_debug = false;;
  35 Http_common.debug := http_debug;;
  36
  37   (* environment settings *)
  38 let daemon_name = "UWOBO OCaml";;
  39 let default_port = 8082;;
  40 let port_env_var = "UWOBO_PORT";;
  41 let port =
  42   try
  43     int_of_string (Sys.getenv port_env_var)
  44   with
  45   | Not_found -> default_port
  46   | Failure "int_of_string" ->
  47       prerr_endline "Warning: invalid port, reverting to default";
  48       default_port
  49 in
  50
  51   (* facilities *)
  52 let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" in
  53 let invocation_error msg outchan =
  54   (* return an ok (200) http response, which display in html an invocation error
  55   message *)
  56   Http_daemon.respond ~body:(pp_error msg) outchan
  57 in
  58 let bad_request body outchan =  (* return a bad request http response *)
  59   Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
  60 in
  61
  62   (* values common to all threads *)
  63 let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
  64 syslogger#enable;
  65 let styles = new Uwobo_styles.styles in
  66 let usage_string = "Help message: not yet written!!" in (* TODO *)
  67
  68   (* thread action *)
  69 let callback req outchan =
  70     (* perform an 'action' that can be applied to a list of keys or, if no
  71     keys was given, to all keys *)
  72   let act_on_keys req styles outchan per_key_action all_keys_action logmsg =
  73     let log = new Uwobo_logger.processingLogger () in
  74     let keys =
  75       try
  76         Pcre.split ~pat:"," (req#param "keys")
  77       with Http_request.Param_not_found _ -> []
  78     in
  79     (match keys with
  80     | [] -> (* no key provided, act on all stylesheets *)
  81         log#log "reloading all stylesheets ...";
  82         (try all_keys_action () with e -> log#log (Printexc.to_string e))
  83     | keys ->
  84         List.iter
  85           (fun key -> (* act on a single stylesheet *)
  86             log#log (sprintf "%s stylesheet %s" logmsg key);
  87             (try per_key_action key with e -> log#log (Printexc.to_string e)))
  88           keys);
  89     Http_daemon.respond ~body:log#asHtml outchan
  90   in
  91   try
  92     syslogger#log `Debug (sprintf "Received request: %s" req#path);
  93     (match req#path with
  94     | "/add" ->
  95         (let bindings = req#paramAll "bind" in
  96         if bindings = [] then
  97           invocation_error "No [key,stylesheet] binding provided" outchan
  98         else begin
  99           let log = new Uwobo_logger.processingLogger () in
 100           List.iter
 101             (fun binding -> (* add a <key, stylesheet> binding *)
 102               let pieces = Pcre.split ~pat:"," binding in
 103               match pieces with
 104               | [key; style] ->
 105                   log#log (sprintf "adding binding <%s,%s>" key style);
 106                   (try
 107                     styles#add key style;
 108                   with e ->
 109                     log#log (Printexc.to_string e))
 110               | _ -> log#log (sprintf "invalid binding %s" binding))
 111             bindings;
 112           Http_daemon.respond ~body:log#asHtml outchan
 113         end)
 114     | "/list" ->
 115         (let log = new Uwobo_logger.processingLogger () in
 116         log#log "Stylesheet list:";
 117         List.iter (fun s -> log#log s) styles#list;
 118         Http_daemon.respond ~body:log#asHtml outchan)
 119     | "/remove" ->
 120         act_on_keys
 121           req styles outchan
 122           styles#remove (fun () -> styles#removeAll) "removing"
 123     | "/reload" ->
 124         act_on_keys
 125           req styles outchan
 126           styles#reload (fun () -> styles#reloadAll) "reloading"
 127     | "/apply" ->
 128         (let logger = new Uwobo_logger.processingLogger () in
 129         let xmluri = req#param "xmluri" in
 130         let keys = Pcre.split ~pat:"," (req#param "keys") in
 131         (* notation: "local" parameters are those defined on a per-stylesheet
 132         pasis (i.e. param.key.param=value), "global" parameters are those
 133         defined for all stylesheets (i.e. param.param=value) *)
 134         let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
 135         let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
 136         let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
 137         let (params, props) =
 138           List.fold_left
 139             (fun (old_params, old_properties) (name, value) ->
 140               match name with
 141               | name when is_global_param name ->
 142                   let name = Pcre.replace ~pat:"^param\\." name in
 143                   ((fun x -> (old_params x) @ [name, value]),
 144                    old_properties)
 145               | name when is_local_param name ->
 146                   let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
 147                   let (key, name) = (pieces.(1), pieces.(2)) in
 148                   ((function
 149                     | x when x = key -> [name, value] @ (old_params x)
 150                     | x -> old_params x),
 151                    old_properties)
 152               | name when is_property name ->
 153                   let name = Pcre.replace ~pat:"^prop\\." name in
 154                   (old_params, ((name, value) :: old_properties))
 155               | _ -> (old_params, old_properties))
 156             ((fun _ -> []), []) (* no parameters, no properties *)
 157             req#params
 158         in
 159         syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
 160         let input = styles#domImpl#createDocumentFromURI ~uri:xmluri () in
 161         let output =
 162           Uwobo_engine.apply ~logger ~styles ~keys ~input ~params ~props
 163           (* TODO uhm ... what to do if Uwobo_failure is raised? *)
 164         in
 165         syslogger#log `Debug logger#asText;
 166         let tempfile = (* temporary file on which save XML output *)
 167           (* TODO I don't need a tempfile, but gdome seems not to permit to
 168           return the string representation of a Gdome.document *)
 169           let inchan = Unix.open_process_in "tempfile --prefix=uwobo" in
 170           let name = input_line inchan in
 171           close_in inchan;
 172           name
 173         in
 174         syslogger#log
 175           `Debug
 176           (sprintf "saving output document to %s ..." tempfile);
 177         let res =
 178           styles#domImpl#saveDocumentToFile ~doc:output ~name:tempfile ()
 179         in
 180         if not res then
 181           raise (Uwobo_failure ("unable to save output to file " ^ tempfile));
 182         syslogger#log `Debug "sending output to client ....";
 183         Http_daemon.send_basic_headers ~code:200 outchan;
 184         (* TODO set Content-Type *)
 185         Http_daemon.send_CRLF outchan;
 186         Http_daemon.send_file ~name:tempfile outchan;
 187         Unix.unlink tempfile)
 188     | "/help" -> Http_daemon.respond ~body:usage_string outchan
 189     | invalid_request ->
 190         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
 191   with
 192   | Http_request.Param_not_found attr_name ->
 193       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 194   | exc ->
 195       Http_daemon.respond
 196         ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
 197         outchan
 198 in
 199
 200   (* daemon initialization *)
 201 syslogger#log
 202   `Notice
 203   (sprintf "%s started and listening on port %d" daemon_name port);
 204 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
 205 Http_daemon.start' ~port ~mode:`Thread callback;
 206 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
 207