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
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 *)
69 let callback req outchan =
71 syslogger#log `Debug (sprintf "Received request: %s" req#path);
74 (let bindings = req#paramAll "bind" in
76 invocation_error "No [key,stylesheet] binding provided" outchan
78 let log = new Uwobo_logger.processingLogger () in
80 (fun binding -> (* add a <key, stylesheet> binding *)
81 let pieces = Pcre.split ~pat:"," binding in
84 log#log (sprintf "adding binding <%s,%s>" key style);
85 Mutex.lock styles_mutex;
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))
96 Http_daemon.respond ~body:log#asHtml outchan
98 | "/remove" -> (* TODO this branch is almost identical to "/reload" one *)
99 (let log = new Uwobo_logger.processingLogger () in
102 Pcre.split ~pat:"," (req#param "keys")
103 with Http_request.Param_not_found _ -> []
106 | [] -> (* no key provided, unload all stylesheets *)
107 log#log "removing all stylesheets ...";
108 Mutex.lock styles_mutex;
114 "failure while removing all stylesheets: exception %s"
115 (Printexc.to_string e)));
116 Mutex.unlock styles_mutex
119 (fun key -> (* remove a single stylesheet *)
120 Mutex.lock styles_mutex;
121 log#log (sprintf "removing stylesheet %s" key);
127 "failure while removing stylesheet %s: exception %s"
128 key (Printexc.to_string e)));
129 Mutex.unlock styles_mutex)
131 Http_daemon.respond ~body:log#asHtml outchan)
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
141 Pcre.split ~pat:"," (req#param "keys")
142 with Http_request.Param_not_found _ -> []
145 | [] -> (* no key provided, reload all stylesheets *)
146 log#log "reloading all stylesheets ...";
147 Mutex.lock styles_mutex;
153 "failure while reloading all stylesheets: exception %s"
154 (Printexc.to_string e)));
155 Mutex.unlock styles_mutex
158 (fun key -> (* reload a single stylesheet *)
159 Mutex.lock styles_mutex;
160 log#log (sprintf "reloading stylesheet %s" key);
166 "failure while reloading stylesheet %s: exception %s"
167 key (Printexc.to_string e)));
168 Mutex.unlock styles_mutex)
170 Http_daemon.respond ~body:log#asHtml outchan)
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) =
183 (fun (old_params, old_properties) (name, value) ->
185 | name when is_global_param name ->
186 let name = Pcre.replace ~pat:"^param\\." name in
187 ((fun x -> (old_params x) @ [name, value]),
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
193 | x when x = key -> [name, value] @ (old_params x)
194 | x -> old_params x),
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 *)
204 ~logger ~styles ~keys ~input:xmluri ~params ~props outchan)
205 | "/help" -> Http_daemon.respond ~body:usage_string outchan
207 Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
209 | Http_request.Param_not_found attr_name ->
210 bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
213 ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
217 (* daemon initialization *)
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)