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/.
30 (* debugging settings *)
32 let debug_level = `Debug;;
33 let debug_print s = if debug then prerr_endline s;;
34 let http_debug = false;;
35 Http_common.debug := http_debug;;
37 (* environment settings *)
38 let daemon_name = "UWOBO OCaml";;
39 let default_port = 8082;;
40 let port_env_var = "UWOBO_PORT";;
43 int_of_string (Sys.getenv port_env_var)
45 | Not_found -> default_port
46 | Failure "int_of_string" ->
47 prerr_endline "Warning: invalid port, reverting to default";
52 let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" in
53 let invocation_error msg outchan =
54 (* return an ok (200) http response, which display in html an invocation error
56 Http_daemon.respond ~body:(pp_error msg) outchan
58 let bad_request body outchan = (* return a bad request http response *)
59 Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
62 (* values common to all threads *)
63 let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
65 let styles = new Uwobo_styles.styles in
66 let usage_string = "Help message: not yet written!!" in (* TODO *)
69 let callback req outchan =
70 (* perform an 'action' that can be applied to a list of keys or, if no
71 keys was given, to all keys *)
72 let act_on_keys req styles outchan per_key_action all_keys_action logmsg =
73 let log = new Uwobo_logger.processingLogger () in
76 Pcre.split ~pat:"," (req#param "keys")
77 with Http_request.Param_not_found _ -> []
80 | [] -> (* no key provided, act on all stylesheets *)
81 log#log "reloading all stylesheets ...";
82 (try all_keys_action () with e -> log#log (Printexc.to_string e))
85 (fun key -> (* act on a single stylesheet *)
86 log#log (sprintf "%s stylesheet %s" logmsg key);
87 (try per_key_action key with e -> log#log (Printexc.to_string e)))
89 Http_daemon.respond ~body:log#asHtml outchan
92 syslogger#log `Debug (sprintf "Received request: %s" req#path);
95 (let bindings = req#paramAll "bind" in
97 invocation_error "No [key,stylesheet] binding provided" outchan
99 let log = new Uwobo_logger.processingLogger () in
101 (fun binding -> (* add a <key, stylesheet> binding *)
102 let pieces = Pcre.split ~pat:"," binding in
105 log#log (sprintf "adding binding <%s,%s>" key style);
107 styles#add key style;
109 log#log (Printexc.to_string e))
110 | _ -> log#log (sprintf "invalid binding %s" binding))
112 Http_daemon.respond ~body:log#asHtml outchan
115 (let log = new Uwobo_logger.processingLogger () in
116 log#log "Stylesheet list:";
117 List.iter (fun s -> log#log s) styles#list;
118 Http_daemon.respond ~body:log#asHtml outchan)
122 styles#remove (fun () -> styles#removeAll) "removing"
126 styles#reload (fun () -> styles#reloadAll) "reloading"
128 (let logger = new Uwobo_logger.processingLogger () in
129 let xmluri = req#param "xmluri" in
130 let keys = Pcre.split ~pat:"," (req#param "keys") in
131 (* notation: "local" parameters are those defined on a per-stylesheet
132 pasis (i.e. param.key.param=value), "global" parameters are those
133 defined for all stylesheets (i.e. param.param=value) *)
134 let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
135 let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
136 let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
137 let (params, props) =
139 (fun (old_params, old_properties) (name, value) ->
141 | name when is_global_param name ->
142 let name = Pcre.replace ~pat:"^param\\." name in
143 ((fun x -> (old_params x) @ [name, value]),
145 | name when is_local_param name ->
146 let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
147 let (key, name) = (pieces.(1), pieces.(2)) in
149 | x when x = key -> [name, value] @ (old_params x)
150 | x -> old_params x),
152 | name when is_property name ->
153 let name = Pcre.replace ~pat:"^prop\\." name in
154 (old_params, ((name, value) :: old_properties))
155 | _ -> (old_params, old_properties))
156 ((fun _ -> []), []) (* no parameters, no properties *)
159 syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
160 let input = styles#domImpl#createDocumentFromURI ~uri:xmluri () in
162 Uwobo_engine.apply ~logger ~styles ~keys ~input ~params ~props
163 (* TODO uhm ... what to do if Uwobo_failure is raised? *)
165 syslogger#log `Debug logger#asText;
166 let tempfile = (* temporary file on which save XML output *)
167 (* TODO I don't need a tempfile, but gdome seems not to permit to
168 return the string representation of a Gdome.document *)
169 let inchan = Unix.open_process_in "tempfile --prefix=uwobo" in
170 let name = input_line inchan in
176 (sprintf "saving output document to %s ..." tempfile);
178 styles#domImpl#saveDocumentToFile ~doc:output ~name:tempfile ()
181 raise (Uwobo_failure ("unable to save output to file " ^ tempfile));
182 syslogger#log `Debug "sending output to client ....";
183 Http_daemon.send_basic_headers ~code:200 outchan;
184 (* TODO set Content-Type *)
185 Http_daemon.send_CRLF outchan;
186 Http_daemon.send_file ~name:tempfile outchan;
187 Unix.unlink tempfile)
188 | "/help" -> Http_daemon.respond ~body:usage_string outchan
190 Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
192 | Http_request.Param_not_found attr_name ->
193 bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
196 ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
200 (* daemon initialization *)
203 (sprintf "%s started and listening on port %d" daemon_name port);
204 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
205 Http_daemon.start' ~port ~mode:`Thread callback;
206 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)