]> matita.cs.unibo.it Git - helm.git/blob - helm/uwobo/src/ocaml/uwobo.ml
- added sanity checks entry
[helm.git] / helm / uwobo / src / ocaml / uwobo.ml
1
2 (* Copyright (C) 2002, HELM Team.
3  * 
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.
7  * 
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.
12  * 
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.
17  *
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,
21  * MA  02111-1307, USA.
22  * 
23  * For details, see the HELM World-Wide-Web page,
24  * http://cs.unibo.it/helm/.
25  *)
26
27 (* TODO braindead situation: /add of a stylesheet which uri is an uwobo
28 invocation *)
29
30 open Printf;;
31 open Uwobo_common;;
32
33  (* debugging settings *)
34 let debug = true;;
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;;
39
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";;
46 let port =
47   try
48     int_of_string (Sys.getenv port_env_var)
49   with
50   | Not_found -> default_port
51   | Failure "int_of_string" ->
52       prerr_endline "Warning: invalid port, reverting to default";
53       default_port
54 in
55
56   (* facilities *)
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
61 in
62 let bad_request body outchan =  (* return a bad request http response *)
63   Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
64 in
65
66   (* values common to all threads *)
67 let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
68 syslogger#enable;
69 let styles = new Uwobo_styles.styles in
70 let usage_string =
71   sprintf
72 "
73 <html>
74   <head>
75     <title>UWOBO's help message</title>
76   </head>
77   <body>
78     <p>
79     Usage: <kbd>http://hostname:uwoboport/</kbd><em>command</em>
80     </p>
81     <p>
82     Available commands:
83     </p>
84     <p>
85       <b><kbd>help</kbd></b><br />
86       display this help message
87     </p>
88     <p>
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
91           <em>key</em>
92     </p>
93     <p>
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
97     </p>
98     <p>
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
102     </p>
103     <p>
104       <b><kbd>list</kbd></b><br />
105       return a list of loaded stylesheets
106     </p>
107     <p>
108       <b><kbd>apply?xmluri=uri&keys=key1,key2,...[&param.name=value[&param.name=value[&...]]][&param.key.name=value[&param.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
115       stylesheet.<br />
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.
120     </p>
121   </body>
122 </html>
123 "
124   (String.concat ", " Uwobo_common.supported_properties)
125 in
126
127   (* thread action *)
128 let callback req 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 styles outchan per_key_action all_keys_action logmsg =
132     let log = new Uwobo_logger.processingLogger () in
133     let keys =
134       try
135         Pcre.split ~pat:"," (req#param "keys")
136       with Http_request.Param_not_found _ -> []
137     in
138     (match keys with
139     | [] -> (* no key provided, act on all stylesheets *)
140         log#log "reloading all stylesheets ...";
141         (try all_keys_action () with e -> log#log (Printexc.to_string e))
142     | keys ->
143         List.iter
144           (fun key -> (* act on a single stylesheet *)
145             log#log (sprintf "%s stylesheet %s" logmsg key);
146             (try per_key_action key with e -> log#log (Printexc.to_string e)))
147           keys);
148     Http_daemon.respond ~body:log#asHtml outchan
149   in
150   let parse_apply_params =  (* parse parameters for '/apply' action *)
151     let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
152     let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
153     let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
154     List.fold_left
155       (fun (old_params, old_properties) (name, value) ->
156         match name with
157         | name when is_global_param name ->
158             let name = Pcre.replace ~pat:"^param\\." name in
159             ((fun x -> (old_params x) @ [name, value]), old_properties)
160         | name when is_local_param name ->
161             let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
162             let (key, name) = (pieces.(1), pieces.(2)) in
163             ((function
164               | x when x = key -> [name, value] @ (old_params x)
165               | x -> old_params x),
166              old_properties)
167         | name when is_property name ->
168             let name = Pcre.replace ~pat:"^prop\\." name in
169             (old_params, ((name, value) :: old_properties))
170         | _ -> (old_params, old_properties))
171       ((fun _ -> []), []) (* no parameters, no properties *)
172   in
173   try
174     syslogger#log `Debug (sprintf "Received request: %s" req#path);
175     (match req#path with
176     | "/add" ->
177         (let bindings = req#paramAll "bind" in
178         if bindings = [] then
179           return_error "No [key,stylesheet] binding provided" outchan
180         else begin
181           let log = new Uwobo_logger.processingLogger () in
182           List.iter
183             (fun binding -> (* add a <key, stylesheet> binding *)
184               let pieces = Pcre.split ~pat:"," binding in
185               match pieces with
186               | [key; style] ->
187                   log#log (sprintf "adding binding <%s,%s>" key style);
188                   (try
189                     styles#add key style;
190                   with e ->
191                     log#log (Printexc.to_string e))
192               | _ -> log#log (sprintf "invalid binding %s" binding))
193             bindings;
194           Http_daemon.respond ~body:log#asHtml outchan
195         end)
196     | "/list" ->
197         (let log = new Uwobo_logger.processingLogger () in
198         log#log "Stylesheet list:";
199         List.iter (fun s -> log#log s) styles#list;
200         Http_daemon.respond ~body:log#asHtml outchan)
201     | "/remove" ->
202         act_on_keys
203           req styles outchan
204           styles#remove (fun () -> styles#removeAll) "removing"
205     | "/reload" ->
206         act_on_keys
207           req styles outchan
208           styles#reload (fun () -> styles#reloadAll) "reloading"
209     | "/apply" ->
210         if Unix.fork () = 0 then
211           (let logger = new Uwobo_logger.processingLogger () in
212           let xmluri = req#param "xmluri" in
213           let keys = Pcre.split ~pat:"," (req#param "keys") in
214           (* notation: "local" parameters are those defined on a per-stylesheet
215           pasis (i.e. param.key.param=value), "global" parameters are those
216           defined for all stylesheets (i.e. param.param=value) *)
217           let (params, props) = parse_apply_params req#params in
218           syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
219           let domImpl = Gdome.domImplementation () in
220           let input = domImpl#createDocumentFromURI ~uri:xmluri () in
221           syslogger#log `Debug "Applying stylesheet chain ...";
222           try
223             let (write_result, media_type, encoding) = (* out_channel -> unit *)
224               Uwobo_engine.apply
225                 ~logger:syslogger ~styles ~keys ~input ~params ~props
226             in
227             let content_type = (* value of Content-Type HTTP response header *)
228               sprintf
229                 "%s; charset=%s"
230                 (match media_type with None -> default_media_type | Some t -> t)
231                 (match encoding with None -> default_encoding | Some e -> e)
232             in
233             syslogger#log
234               `Debug
235               (sprintf
236                 "sending output to client (Content-Type: %s)...."
237                 content_type);
238             Http_daemon.send_basic_headers ~code:200 outchan;
239             Http_daemon.send_header "Content-Type" content_type outchan;
240             Http_daemon.send_CRLF outchan;
241             write_result outchan
242           with Uwobo_failure errmsg ->
243             return_error
244               (sprintf "Stylesheet chain application failed: %s" errmsg)
245               outchan)
246     | "/help" -> Http_daemon.respond ~body:usage_string outchan
247     | invalid_request ->
248         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
249   with
250   | Http_request.Param_not_found attr_name ->
251       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
252   | exc ->
253       Http_daemon.respond
254         ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
255         outchan
256 in
257
258   (* daemon initialization *)
259 syslogger#log
260   `Notice
261   (sprintf "%s started and listening on port %d" daemon_name port);
262 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
263 Unix.putenv "http_proxy" "";  (* reset http_proxy to avoid libxslt problems *)
264 Http_daemon.start' ~port ~mode:`Thread callback;
265 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
266