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 syslogger#enable;
  64 let styles = new Uwobo_styles.styles in
  65 let styles_mutex = Mutex.create () in
  66 let usage_string = "Help message: not yet written!!" in (* TODO *)
  67
  68   (* thread action *)
  69 let callback req outchan =
  70   try
  71     syslogger#log `Debug (sprintf "Received request: %s" req#path);
  72     (match req#path with
  73     | "/add" ->
  74         (let bindings = req#paramAll "bind" in
  75         if bindings = [] then
  76           invocation_error "No [key,stylesheet] binding provided" outchan
  77         else begin
  78           let log = new Uwobo_logger.processingLogger () in
  79           List.iter
  80             (fun binding -> (* add a <key, stylesheet> binding *)
  81               let pieces = Pcre.split ~pat:"," binding in
  82               match pieces with
  83               | [key; style] ->
  84                   log#log (sprintf "adding binding <%s,%s>" key style);
  85                   Mutex.lock styles_mutex;
  86                   (try
  87                     styles#add key style;
  88                   with e ->
  89                     log#log
  90                       (sprintf
  91                         "failure while adding <%s,%s>: exception %s"
  92                         key style (Printexc.to_string e)));
  93                   Mutex.unlock styles_mutex
  94               | _ -> log#log (sprintf "invalid binding %s" binding))
  95             bindings;
  96           Http_daemon.respond ~body:log#asHtml outchan
  97         end)
  98     | "/remove" ->  (* TODO this branch is almost identical to "/reload" one *)
  99         (let log = new Uwobo_logger.processingLogger () in
 100         let keys =
 101           try
 102             Pcre.split ~pat:"," (req#param "keys")
 103           with Http_request.Param_not_found _ -> []
 104         in
 105         (match keys with
 106         | [] -> (* no key provided, unload all stylesheets *)
 107             log#log "removing all stylesheets ...";
 108             Mutex.lock styles_mutex;
 109             (try
 110               styles#removeAll
 111             with e ->
 112               log#log
 113                 (sprintf
 114                   "failure while removing all stylesheets: exception %s"
 115                   (Printexc.to_string e)));
 116             Mutex.unlock styles_mutex
 117         | keys ->
 118             List.iter
 119               (fun key -> (* remove a single stylesheet *)
 120                 Mutex.lock styles_mutex;
 121                 log#log (sprintf "removing stylesheet %s" key);
 122                 (try
 123                   styles#remove key
 124                 with e ->
 125                   log#log
 126                     (sprintf
 127                       "failure while removing stylesheet %s: exception %s"
 128                       key (Printexc.to_string e)));
 129                 Mutex.unlock styles_mutex)
 130               keys);
 131         Http_daemon.respond ~body:log#asHtml outchan)
 132     | "/list" ->
 133         (let log = new Uwobo_logger.processingLogger () in
 134         log#log "Stylesheet list:";
 135         styles#iterKeys (fun k -> log#log (styles#getInfo k));
 136         Http_daemon.respond ~body:log#asHtml outchan)
 137     | "/reload" ->  (* TODO this branch is almost identical to "/remove" one *)
 138         (let log = new Uwobo_logger.processingLogger () in
 139         let keys =
 140           try
 141             Pcre.split ~pat:"," (req#param "keys")
 142           with Http_request.Param_not_found _ -> []
 143         in
 144         (match keys with
 145         | [] -> (* no key provided, reload all stylesheets *)
 146           log#log "reloading all stylesheets ...";
 147           Mutex.lock styles_mutex;
 148           (try
 149             styles#reloadAll
 150           with e ->
 151             log#log
 152               (sprintf
 153                 "failure while reloading all stylesheets: exception %s"
 154                 (Printexc.to_string e)));
 155           Mutex.unlock styles_mutex
 156         | keys ->
 157             List.iter
 158               (fun key -> (* reload a single stylesheet *)
 159                 Mutex.lock styles_mutex;
 160                 log#log (sprintf "reloading stylesheet %s" key);
 161                 (try
 162                   styles#reload key
 163                 with e ->
 164                   log#log
 165                     (sprintf
 166                       "failure while reloading stylesheet %s: exception %s"
 167                       key (Printexc.to_string e)));
 168                 Mutex.unlock styles_mutex)
 169               keys);
 170         Http_daemon.respond ~body:log#asHtml outchan)
 171     | "/apply" ->
 172         (let logger = new Uwobo_logger.processingLogger () in
 173         let xmluri = req#param "xmluri" in
 174         let keys = Pcre.split ~pat:"," (req#param "keys") in
 175         (* notation: "local" parameters are those defined on a per-stylesheet
 176         pasis (i.e. param.key.param=value), "global" parameters are those
 177         defined for all stylesheets (i.e. param.param=value) *)
 178         let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
 179         let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
 180         let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
 181         let (params, props) =
 182           List.fold_left
 183             (fun (old_params, old_properties) (name, value) ->
 184               match name with
 185               | name when is_global_param name ->
 186                   let name = Pcre.replace ~pat:"^param\\." name in
 187                   ((fun x -> (old_params x) @ [name, value]),
 188                    old_properties)
 189               | name when is_local_param name ->
 190                   let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
 191                   let (key, name) = (pieces.(1), pieces.(2)) in
 192                   ((function
 193                     | x when x = key -> [name, value] @ (old_params x)
 194                     | x -> old_params x),
 195                    old_properties)
 196               | name when is_property name ->
 197                   let name = Pcre.replace ~pat:"^prop\\." name in
 198                   (old_params, ((name, value) :: old_properties))
 199               | _ -> (old_params, old_properties))
 200             ((fun _ -> []), []) (* no parameters, no properties *)
 201             req#params
 202         in
 203         Uwobo_engine.apply
 204           ~logger ~styles ~keys ~input:xmluri ~params ~props outchan)
 205     | "/help" -> Http_daemon.respond ~body:usage_string outchan
 206     | invalid_request ->
 207         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
 208   with
 209   | Http_request.Param_not_found attr_name ->
 210       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 211   | exc ->
 212       Http_daemon.respond
 213         ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
 214         outchan
 215 in
 216
 217   (* daemon initialization *)
 218 syslogger#log
 219   `Notice
 220   (sprintf "%s started and listening on port %d" daemon_name port);
 221 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
 222 Http_daemon.start' ~port ~mode:`Thread callback;
 223 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
 224