(* Copyright (C) 2002, HELM Team. * * This file is part of HELM, an Hypertextual, Electronic * Library of Mathematics, developed at the Computer Science * Department, University of Bologna, Italy. * * HELM is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * HELM is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with HELM; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, * MA 02111-1307, USA. * * For details, see the HELM World-Wide-Web page, * http://cs.unibo.it/helm/. *) open Printf;; (* debugging settings *) let debug = true;; let debug_level = `Debug;; let debug_print s = if debug then prerr_endline s;; let http_debug = false;; Http_common.debug := http_debug;; (* environment settings *) let daemon_name = "UWOBO OCaml";; let default_port = 8082;; let port_env_var = "UWOBO_PORT";; let port = try int_of_string (Sys.getenv port_env_var) with | Not_found -> default_port | Failure "int_of_string" -> prerr_endline "Warning: invalid port, reverting to default"; default_port in (* facilities *) let pp_error = sprintf "

Error: %s

" in let invocation_error msg outchan = (* return an ok (200) http response, which display in html an invocation error message *) Http_daemon.respond ~body:(pp_error msg) outchan in let bad_request body outchan = (* return a bad request http response *) Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan in (* values common to all threads *) let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in let styles = new Uwobo_styles.styles in let styles_mutex = Mutex.create () in let usage_string = "Help message: not yet written!!" in (* TODO *) (* thread action *) let callback req outchan = try (match req#path with | "/add" -> (let bindings = req#param_all "bind" in if bindings = [] then invocation_error "No [key,stylesheet] binding provided" outchan else begin let log = new Uwobo_logger.processingLogger () in List.iter (fun binding -> (* add a binding *) let pieces = Pcre.split ~pat:"," binding in match pieces with | [key; style] -> log#log (sprintf "adding binding <%s,%s>" key style); Mutex.lock styles_mutex; (try styles#add key style; with e -> log#log (sprintf "failure while adding <%s,%s>: exception %s" key style (Printexc.to_string e))); Mutex.unlock styles_mutex | _ -> log#log (sprintf "invalid binding %s" binding)) bindings; Http_daemon.respond ~body:log#asHtml outchan end) | "/remove" -> (* TODO this branch is almost identical to "/reload" one *) (let log = new Uwobo_logger.processingLogger () in (match (Pcre.split ~pat:"," (req#param "keys")) with | [] -> (* no key provided, unload all stylesheets *) log#log "removing all stylesheets ..."; Mutex.lock styles_mutex; (try styles#removeAll with e -> log#log (sprintf "failure while removing all stylesheets: exception %s" (Printexc.to_string e))); Mutex.unlock styles_mutex | keys -> List.iter (fun key -> (* remove a single stylesheet *) Mutex.lock styles_mutex; log#log (sprintf "removing stylesheet %s" key); (try styles#remove key with e -> log#log (sprintf "failure while removing stylesheet %s: exception %s" key (Printexc.to_string e))); Mutex.unlock styles_mutex) keys); Http_daemon.respond ~body:log#asHtml outchan) | "/list" -> (let log = new Uwobo_logger.processingLogger () in log#log "Stylesheet list:"; styles#iterKeys (fun k -> log#log (styles#getInfo k)); Http_daemon.respond ~body:log#asHtml outchan) | "/reload" -> (* TODO this branch is almost identical to "/remove" one *) (let log = new Uwobo_logger.processingLogger () in (match (Pcre.split ~pat:"," (req#param "keys")) with | [] -> (* no key provided, reload all stylesheets *) log#log "reloading all stylesheets ..."; Mutex.lock styles_mutex; (try styles#reloadAll with e -> log#log (sprintf "failure while reloading all stylesheets: exception %s" (Printexc.to_string e))); Mutex.unlock styles_mutex | keys -> List.iter (fun key -> (* reload a single stylesheet *) Mutex.lock styles_mutex; log#log (sprintf "reloading stylesheet %s" key); (try styles#reload key with e -> log#log (sprintf "failure while reloading stylesheet %s: exception %s" key (Printexc.to_string e))); Mutex.unlock styles_mutex) keys); Http_daemon.respond ~body:log#asHtml outchan) | "/apply" -> (let logger = new Uwobo_logger.processingLogger () in let xmluri = req#param "xmluri" in let keys = Pcre.split ~pat:"," (req#param "keys") in (* notation: "local" parameters are those defined on a per-stylesheet pasis (i.e. param.key.param=value), "global" parameters are those defined for all stylesheets (i.e. param.param=value) *) let local_params = ref [] in (* association list *) let global_params = ref [] in (* association list *) let properties = ref [] in (* association list *) let get_style_param key name = let params = (* try local params and fallback on global params *) try List.assoc key !local_params with Not_found -> global_params in List.assoc name !params (* may raise Not_found *) in let get_property name = List.assoc name !properties in let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}" x in let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}" x in let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+" x in let add_global_param name value = let name = Pcre.replace ~pat:"^param\\." name in global_params := (name, value) :: !global_params in let add_local_param name value = let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in let (key, param) = (pieces.(1), pieces.(2)) in (try let previous_params = List.assoc key !local_params in let new_params = (param, value) :: previous_params in local_params := new_params :: (List.remove_assoc key !local_params) with Not_found -> (* first local parameter for 'key' *) local_params := [(param, value)] :: !local_params) in let add_property name value = properties := (Pcre.replace ~pat:"^prop\\." name, value) :: !properties in List.iter (fun (name, value) -> match name with | name when is_global_param name -> add_global_param name value | name when is_local_param name -> add_local_param name value | name when is_property name -> add_property name value | _ -> ()) req#params; Uwobo_engine.apply ~logger ~styles ~keys ~input:xmluri ~params:get_style_param ~props:get_property outchan) | "/help" -> Http_daemon.respond ~body:usage_string outchan | invalid_request -> Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan) with | Http_request.Param_not_found attr_name -> bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan | exc -> Http_daemon.respond ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc))) outchan in (* daemon initialization *) syslogger#log `Notice (sprintf "%s started and listening on port %d\n" daemon_name port); syslogger#log `Notice (sprintf "current directory is %s\n" (Sys.getcwd ())); Http_daemon.start' ~port ~mode:`Thread callback; syslogger#log `Notice (sprintf "%s is terminating, bye!\n" daemon_name)