--- /dev/null
+
+(* 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 "<html><body><h1>Error: %s</h1></body></html>" 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 <key, stylesheet> 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 <key, parameters> *)
+ let global_params = ref [] in (* association list <name, value> *)
+ let properties = ref [] in (* association list <name, value> *)
+ 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)
+
projects / helm.git / commitdiff