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/.
27 (* TODO braindead situation: /add of a stylesheet which uri is an uwobo
33 (* debugging settings *)
35 let debug_level = `Debug;;
36 let debug_print s = if debug then prerr_endline s;;
37 let http_debug = false;;
38 Http_common.debug := http_debug;;
40 (* environment settings *)
41 let daemon_name = "UWOBO OCaml";;
42 let default_port = 8082;;
43 let port_env_var = "UWOBO_PORT";;
44 let default_media_type = "text/html";;
45 let default_encoding = "utf8";;
48 int_of_string (Sys.getenv port_env_var)
50 | Not_found -> default_port
51 | Failure "int_of_string" ->
52 prerr_endline "Warning: invalid port, reverting to default";
57 let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" in
58 let return_error msg outchan =
59 (* return an ok (200) http response, which display in html an error message *)
60 Http_daemon.respond ~body:(pp_error msg) outchan
62 let bad_request body outchan = (* return a bad request http response *)
63 Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
66 (* values common to all threads *)
67 let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
69 let styles = new Uwobo_styles.styles in
75 <title>UWOBO's help message</title>
79 Usage: <kbd>http://hostname:uwoboport/</kbd><em>command</em>
85 <b><kbd>help</kbd></b><br />
86 display this help message
89 <b><kbd>add?bind=key,uri[&bind=key,stylesheet[&...]]</kbd></b><br />
90 load a new stylesheet, specified by <em>uri</em>, and bind it to key
94 <b><kbd>remove?[?keys=key1,key2,...]</kbd></b><br />
95 unload stylesheets specified by <em>key1, key2, ...</em> or all
96 stylesheets if no key was given
99 <b><kbd>reload?[?keys=key1,key2,...]</kbd></b><br />
100 reload stylesheets specified by <em>key1, key2, ...</em> or all
101 stylesheets if no key was given
104 <b><kbd>list</kbd></b><br />
105 return a list of loaded stylesheets
108 <b><kbd>apply?xmluri=uri&keys=key1,key2,...[¶m.name=value[¶m.name=value[&...]]][¶m.key.name=value[¶m.key.name=value[&...]]][&name[=value][&prop.name[=value][&...]]]</kbd></b><br />
109 apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
110 input document, specified by <em>uri</em>.<br />
111 Additional parameters can be set for each stylesheet application: global
112 parameters (i.e. parameters passed to all stylesheets) are set using
113 <em>param.name=value</em> syntax, per stylesheet parameters are set using
114 <em>param.key.name=value</em> where <em>key</em> is the key of a loaded
116 Properties of the final chain output can be set too: valueless properties
117 can be set using <em>prop.name</em> syntax, others can be set using
118 <em>prop.name=value</em> syntax.<br />
119 Current supported properties are: %s.
124 (String.concat ", " Uwobo_common.supported_properties)
128 let callback (req: Http_types.request) outchan =
129 (* perform an 'action' that can be applied to a list of keys or, if no
130 keys was given, to all keys *)
131 let act_on_keys (req: Http_types.request)
132 styles outchan per_key_action all_keys_action logmsg
134 let log = new Uwobo_logger.processingLogger () in
137 Pcre.split ~pat:"," (req#param "keys")
138 with Http_types.Param_not_found _ -> []
141 | [] -> (* no key provided, act on all stylesheets *)
142 log#log "reloading all stylesheets ...";
143 (try all_keys_action () with e -> log#log (Printexc.to_string e))
146 (fun key -> (* act on a single stylesheet *)
147 log#log (sprintf "%s stylesheet %s" logmsg key);
148 (try per_key_action key with e -> log#log (Printexc.to_string e)))
150 Http_daemon.respond ~body:log#asHtml outchan
152 let parse_apply_params = (* parse parameters for '/apply' action *)
153 let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
154 let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
155 let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
157 (fun (old_params, old_properties) (name, value) ->
159 | name when is_global_param name ->
160 let name = Pcre.replace ~pat:"^param\\." name in
161 ((fun x -> (old_params x) @ [name, value]), old_properties)
162 | name when is_local_param name ->
163 let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
164 let (key, name) = (pieces.(1), pieces.(2)) in
166 | x when x = key -> [name, value] @ (old_params x)
167 | x -> old_params x),
169 | name when is_property name ->
170 let name = Pcre.replace ~pat:"^prop\\." name in
171 (old_params, ((name, value) :: old_properties))
172 | _ -> (old_params, old_properties))
173 ((fun _ -> []), []) (* no parameters, no properties *)
176 syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
177 syslogger#log `Debug (sprintf "Received request: %s" req#path);
180 (let bindings = req#paramAll "bind" in
181 if bindings = [] then
182 return_error "No [key,stylesheet] binding provided" outchan
184 let log = new Uwobo_logger.processingLogger () in
186 (fun binding -> (* add a <key, stylesheet> binding *)
187 let pieces = Pcre.split ~pat:"," binding in
190 log#log (sprintf "adding binding <%s,%s>" key style);
192 styles#add key style;
194 log#log (Printexc.to_string e))
195 | _ -> log#log (sprintf "invalid binding %s" binding))
197 Http_daemon.respond ~body:log#asHtml outchan
200 (let log = new Uwobo_logger.processingLogger () in
201 log#log "Stylesheet list:";
202 List.iter (fun s -> log#log s) styles#list;
203 Http_daemon.respond ~body:log#asHtml outchan)
207 styles#remove (fun () -> styles#removeAll) "removing"
211 styles#reload (fun () -> styles#reloadAll) "reloading"
213 if Unix.fork () = 0 then
214 (let logger = new Uwobo_logger.processingLogger () in
215 let xmluri = req#param "xmluri" in
216 let keys = Pcre.split ~pat:"," (req#param "keys") in
217 (* notation: "local" parameters are those defined on a per-stylesheet
218 pasis (i.e. param.key.param=value), "global" parameters are those
219 defined for all stylesheets (i.e. param.param=value) *)
220 let (params, props) = parse_apply_params req#params in
221 syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
222 let domImpl = Gdome.domImplementation () in
223 let input = domImpl#createDocumentFromURI ~uri:xmluri () in
224 syslogger#log `Debug "Applying stylesheet chain ...";
226 let (write_result, media_type, encoding) = (* out_channel -> unit *)
228 ~logger:syslogger ~styles ~keys ~input ~params ~props
230 let content_type = (* value of Content-Type HTTP response header *)
233 (match media_type with None -> default_media_type | Some t -> t)
234 (match encoding with None -> default_encoding | Some e -> e)
239 "sending output to client (Content-Type: %s)...."
241 Http_daemon.send_basic_headers ~code:200 outchan;
242 Http_daemon.send_header "Content-Type" content_type outchan;
243 Http_daemon.send_CRLF outchan;
245 with Uwobo_failure errmsg ->
247 (sprintf "Stylesheet chain application failed: %s" errmsg)
249 | "/help" -> Http_daemon.respond ~body:usage_string outchan
251 Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
252 syslogger#log `Debug (sprintf "%s done!" req#path);
254 | Http_types.Param_not_found attr_name ->
255 bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
258 ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
262 (* daemon initialization *)
265 (sprintf "%s started and listening on port %d" daemon_name port);
266 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
267 Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *)
268 Http_daemon.start' ~port ~mode:`Thread callback;
269 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)