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
  29  (* debugging settings *)
  30 let debug = true;;
  31 let debug_level = `Debug;;
  32 let debug_print s = if debug then prerr_endline s;;
  33 let http_debug = false;;
  34 Http_common.debug := http_debug;;
  35
  36   (* environment settings *)
  37 let daemon_name = "UWOBO OCaml";;
  38 let default_port = 8082;;
  39 let port_env_var = "UWOBO_PORT";;
  40 let port =
  41   try
  42     int_of_string (Sys.getenv port_env_var)
  43   with
  44   | Not_found -> default_port
  45   | Failure "int_of_string" ->
  46       prerr_endline "Warning: invalid port, reverting to default";
  47       default_port
  48 in
  49
  50   (* facilities *)
  51 let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" in
  52 let invocation_error msg outchan =
  53   (* return an ok (200) http response, which display in html an invocation error
  54   message *)
  55   Http_daemon.respond ~body:(pp_error msg) outchan
  56 in
  57 let bad_request body outchan =  (* return a bad request http response *)
  58   Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
  59 in
  60
  61   (* values common to all threads *)
  62 let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
  63 let styles = new Uwobo_styles.styles in
  64 let styles_mutex = Mutex.create () in
  65 let usage_string = "Help message: not yet written!!" in (* TODO *)
  66
  67   (* thread action *)
  68 let callback req outchan =
  69   try
  70     (match req#path with
  71     | "/add" ->
  72         (let bindings = req#param_all "bind" in
  73         if bindings = [] then
  74           invocation_error "No [key,stylesheet] binding provided" outchan
  75         else begin
  76           let log = new Uwobo_logger.processingLogger () in
  77           List.iter
  78             (fun binding -> (* add a <key, stylesheet> binding *)
  79               let pieces = Pcre.split ~pat:"," binding in
  80               match pieces with
  81               | [key; style] ->
  82                   log#log (sprintf "adding binding <%s,%s>" key style);
  83                   Mutex.lock styles_mutex;
  84                   (try
  85                     styles#add key style;
  86                   with e ->
  87                     log#log
  88                       (sprintf
  89                         "failure while adding <%s,%s>: exception %s"
  90                         key style (Printexc.to_string e)));
  91                   Mutex.unlock styles_mutex
  92               | _ -> log#log (sprintf "invalid binding %s" binding))
  93             bindings;
  94           Http_daemon.respond ~body:log#asHtml outchan
  95         end)
  96     | "/remove" ->  (* TODO this branch is almost identical to "/reload" one *)
  97         (let log = new Uwobo_logger.processingLogger () in
  98         (match (Pcre.split ~pat:"," (req#param "keys")) with
  99         | [] -> (* no key provided, unload all stylesheets *)
 100             log#log "removing all stylesheets ...";
 101             Mutex.lock styles_mutex;
 102             (try
 103               styles#removeAll
 104             with e ->
 105               log#log
 106                 (sprintf
 107                   "failure while removing all stylesheets: exception %s"
 108                   (Printexc.to_string e)));
 109             Mutex.unlock styles_mutex
 110         | keys ->
 111             List.iter
 112               (fun key -> (* remove a single stylesheet *)
 113                 Mutex.lock styles_mutex;
 114                 log#log (sprintf "removing stylesheet %s" key);
 115                 (try
 116                   styles#remove key
 117                 with e ->
 118                   log#log
 119                     (sprintf
 120                       "failure while removing stylesheet %s: exception %s"
 121                       key (Printexc.to_string e)));
 122                 Mutex.unlock styles_mutex)
 123               keys);
 124         Http_daemon.respond ~body:log#asHtml outchan)
 125     | "/list" ->
 126         (let log = new Uwobo_logger.processingLogger () in
 127         log#log "Stylesheet list:";
 128         styles#iterKeys (fun k -> log#log (styles#getInfo k));
 129         Http_daemon.respond ~body:log#asHtml outchan)
 130     | "/reload" ->  (* TODO this branch is almost identical to "/remove" one *)
 131         (let log = new Uwobo_logger.processingLogger () in
 132         (match (Pcre.split ~pat:"," (req#param "keys")) with
 133         | [] -> (* no key provided, reload all stylesheets *)
 134           log#log "reloading all stylesheets ...";
 135           Mutex.lock styles_mutex;
 136           (try
 137             styles#reloadAll
 138           with e ->
 139             log#log
 140               (sprintf
 141                 "failure while reloading all stylesheets: exception %s"
 142                 (Printexc.to_string e)));
 143           Mutex.unlock styles_mutex
 144         | keys ->
 145             List.iter
 146               (fun key -> (* reload a single stylesheet *)
 147                 Mutex.lock styles_mutex;
 148                 log#log (sprintf "reloading stylesheet %s" key);
 149                 (try
 150                   styles#reload key
 151                 with e ->
 152                   log#log
 153                     (sprintf
 154                       "failure while reloading stylesheet %s: exception %s"
 155                       key (Printexc.to_string e)));
 156                 Mutex.unlock styles_mutex)
 157               keys);
 158         Http_daemon.respond ~body:log#asHtml outchan)
 159     | "/apply" ->
 160         (let logger = new Uwobo_logger.processingLogger () in
 161         let xmluri = req#param "xmluri" in
 162         let keys = Pcre.split ~pat:"," (req#param "keys") in
 163         (* notation: "local" parameters are those defined on a per-stylesheet
 164         pasis (i.e. param.key.param=value), "global" parameters are those
 165         defined for all stylesheets (i.e. param.param=value) *)
 166         let local_params = ref [] in  (* association list <key, parameters> *)
 167         let global_params = ref [] in (* association list <name, value> *)
 168         let properties = ref [] in    (* association list <name, value> *)
 169         let get_style_param key name =
 170           let params =  (* try local params and fallback on global params *)
 171             try List.assoc key !local_params with Not_found -> global_params
 172           in
 173           List.assoc name !params  (* may raise Not_found *)
 174         in
 175         let get_property name = List.assoc name !properties in
 176         let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}" x in
 177         let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}" x in
 178         let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+" x in
 179         let add_global_param name value =
 180           let name = Pcre.replace ~pat:"^param\\." name in
 181           global_params := (name, value) :: !global_params
 182         in
 183         let add_local_param name value =
 184           let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
 185           let (key, param) = (pieces.(1), pieces.(2)) in
 186           (try
 187             let previous_params = List.assoc key !local_params in
 188             let new_params = (param, value) :: previous_params in
 189             local_params := new_params :: (List.remove_assoc key !local_params)
 190           with Not_found -> (* first local parameter for 'key' *)
 191             local_params := [(param, value)] :: !local_params)
 192         in
 193         let add_property name value =
 194           properties :=
 195             (Pcre.replace ~pat:"^prop\\." name, value) :: !properties
 196         in
 197         List.iter
 198           (fun (name, value) ->
 199             match name with
 200             | name when is_global_param name -> add_global_param name value
 201             | name when is_local_param name -> add_local_param name value
 202             | name when is_property name -> add_property name value
 203             | _ -> ())
 204           req#params;
 205         Uwobo_engine.apply
 206           ~logger ~styles ~keys ~input:xmluri
 207           ~params:get_style_param ~props:get_property
 208           outchan)
 209     | "/help" -> Http_daemon.respond ~body:usage_string outchan
 210     | invalid_request ->
 211         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
 212   with
 213   | Http_request.Param_not_found attr_name ->
 214       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 215   | exc ->
 216       Http_daemon.respond
 217         ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
 218         outchan
 219 in
 220
 221   (* daemon initialization *)
 222 syslogger#log
 223   `Notice
 224   (sprintf "%s started and listening on port %d\n" daemon_name port);
 225 syslogger#log `Notice (sprintf "current directory is %s\n" (Sys.getcwd ()));
 226 Http_daemon.start' ~port ~mode:`Thread callback;
 227 syslogger#log `Notice (sprintf "%s is terminating, bye!\n" daemon_name)
 228