2 (* Copyright (C) 2002, HELM Team.
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.
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.
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.
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,
23 * For details, see the HELM World-Wide-Web page,
24 * http://cs.unibo.it/helm/.
29 (* debugging settings *)
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;;
36 (* environment settings *)
37 let daemon_name = "UWOBO OCaml";;
38 let default_port = 8082;;
39 let port_env_var = "UWOBO_PORT";;
42 int_of_string (Sys.getenv port_env_var)
44 | Not_found -> default_port
45 | Failure "int_of_string" ->
46 prerr_endline "Warning: invalid port, reverting to default";
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
55 Http_daemon.respond ~body:(pp_error msg) outchan
57 let bad_request body outchan = (* return a bad request http response *)
58 Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
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 *)
68 let callback req outchan =
72 (let bindings = req#param_all "bind" in
74 invocation_error "No [key,stylesheet] binding provided" outchan
76 let log = new Uwobo_logger.processingLogger () in
78 (fun binding -> (* add a <key, stylesheet> binding *)
79 let pieces = Pcre.split ~pat:"," binding in
82 log#log (sprintf "adding binding <%s,%s>" key style);
83 Mutex.lock styles_mutex;
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))
94 Http_daemon.respond ~body:log#asHtml outchan
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;
107 "failure while removing all stylesheets: exception %s"
108 (Printexc.to_string e)));
109 Mutex.unlock styles_mutex
112 (fun key -> (* remove a single stylesheet *)
113 Mutex.lock styles_mutex;
114 log#log (sprintf "removing stylesheet %s" key);
120 "failure while removing stylesheet %s: exception %s"
121 key (Printexc.to_string e)));
122 Mutex.unlock styles_mutex)
124 Http_daemon.respond ~body:log#asHtml outchan)
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;
141 "failure while reloading all stylesheets: exception %s"
142 (Printexc.to_string e)));
143 Mutex.unlock styles_mutex
146 (fun key -> (* reload a single stylesheet *)
147 Mutex.lock styles_mutex;
148 log#log (sprintf "reloading stylesheet %s" key);
154 "failure while reloading stylesheet %s: exception %s"
155 key (Printexc.to_string e)));
156 Mutex.unlock styles_mutex)
158 Http_daemon.respond ~body:log#asHtml outchan)
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
173 List.assoc name !params (* may raise Not_found *)
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
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
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)
193 let add_property name value =
195 (Pcre.replace ~pat:"^prop\\." name, value) :: !properties
198 (fun (name, value) ->
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
206 ~logger ~styles ~keys ~input:xmluri
207 ~params:get_style_param ~props:get_property
209 | "/help" -> Http_daemon.respond ~body:usage_string outchan
211 Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
213 | Http_request.Param_not_found attr_name ->
214 bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
217 ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
221 (* daemon initialization *)
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)