X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fsrc%2Focaml%2Fuwobo.ml;h=abe65f47c135753548e7956a1cde734ce27dde00;hb=285f5b4454e34023e57b21d4b6b908979aa79a69;hp=fef1c0d91bc4c81bc8c051186278bad682fad146;hpb=de72c4ad2f799cfb2a2e23fadc14235a6e1c76e8;p=helm.git
diff --git a/helm/uwobo/src/ocaml/uwobo.ml b/helm/uwobo/src/ocaml/uwobo.ml
index fef1c0d91..abe65f47c 100644
--- a/helm/uwobo/src/ocaml/uwobo.ml
+++ b/helm/uwobo/src/ocaml/uwobo.ml
@@ -24,6 +24,9 @@
* http://cs.unibo.it/helm/.
*)
+(* TODO braindead situation: /add of a stylesheet which uri is an uwobo
+invocation *)
+
open Printf;;
open Uwobo_common;;
@@ -31,14 +34,14 @@ open Uwobo_common;;
let debug = true;;
let debug_level = `Debug;;
let debug_print s = if debug then prerr_endline s;;
-let http_debug = false;;
+let http_debug = true;;
Http_common.debug := http_debug;;
(* environment settings *)
let daemon_name = "UWOBO OCaml";;
let default_port = 8082;;
let port_env_var = "UWOBO_PORT";;
-let default_media_type = "text/xml";;
+let default_media_type = "text/html";;
let default_encoding = "utf8";;
let port =
try
@@ -64,7 +67,62 @@ in
let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
syslogger#enable;
let styles = new Uwobo_styles.styles in
-let usage_string = "Help message: not yet written!!" in (* TODO *)
+let usage_string =
+ sprintf
+"
+
+
+ UWOBO's help message
+
+
+
+ Usage: http://hostname:uwoboport/command
+
+
+ Available commands:
+
+
+ help
+ display this help message
+
+
+ add?bind=key,uri[&bind=key,stylesheet[&...]]
+ load a new stylesheet, specified by uri, and bind it to key
+ key
+
+
+ remove?[?keys=key1,key2,...]
+ unload stylesheets specified by key1, key2, ... or all
+ stylesheets if no key was given
+
+
+ reload?[?keys=key1,key2,...]
+ reload stylesheets specified by key1, key2, ... or all
+ stylesheets if no key was given
+
+
+ list
+ return a list of loaded stylesheets
+
+
+ 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][&...]]]
+ apply a chain of stylesheets, specified by key1, key2, ..., to an
+ input document, specified by uri.
+ Additional parameters can be set for each stylesheet application: global
+ parameters (i.e. parameters passed to all stylesheets) are set using
+ param.name=value syntax, per stylesheet parameters are set using
+ param.key.name=value where key is the key of a loaded
+ stylesheet.
+ Properties of the final chain output can be set too: valueless properties
+ can be set using prop.name syntax, others can be set using
+ prop.name=value syntax.
+ Current supported properties are: %s.
+
+
+
+"
+ (String.concat ", " Uwobo_common.supported_properties)
+in
(* thread action *)
let callback req outchan =
@@ -75,7 +133,7 @@ let callback req outchan =
let keys =
try
Pcre.split ~pat:"," (req#param "keys")
- with Http_request.Param_not_found _ -> []
+ with Http_types.Param_not_found _ -> []
in
(match keys with
| [] -> (* no key provided, act on all stylesheets *)
@@ -113,6 +171,7 @@ let callback req outchan =
((fun _ -> []), []) (* no parameters, no properties *)
in
try
+ syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
syslogger#log `Debug (sprintf "Received request: %s" req#path);
(match req#path with
| "/add" ->
@@ -149,42 +208,47 @@ let callback req outchan =
req styles outchan
styles#reload (fun () -> styles#reloadAll) "reloading"
| "/apply" ->
- (let logger = new Uwobo_logger.processingLogger () in
- let xmluri = req#param "xmluri" in
- let keys = Pcre.split ~pat:"," (req#param "keys") in
- (* notation: "local" parameters are those defined on a per-stylesheet
- pasis (i.e. param.key.param=value), "global" parameters are those
- defined for all stylesheets (i.e. param.param=value) *)
- let (params, props) = parse_apply_params req#params in
- syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
- let domImpl = Gdome.domImplementation () in
- let input = domImpl#createDocumentFromURI ~uri:xmluri () in
- syslogger#log `Debug "Applying stylesheet chain ...";
- try
- let (write_result, media_type, encoding) = (* out_channel -> unit *)
- Uwobo_engine.apply
- ~logger:syslogger ~styles ~keys ~input ~params ~props
- in
- let content_type = (* value of Content-Type HTTP response header *)
- sprintf
- "%s; charset=%s"
- (match media_type with None -> default_media_type | Some t -> t)
- (match encoding with None -> default_encoding | Some e -> e)
- in
- syslogger#log `Debug "sending output to client ....";
- Http_daemon.send_basic_headers ~code:200 outchan;
- Http_daemon.send_header "Content-Type" content_type outchan;
- Http_daemon.send_CRLF outchan;
- write_result outchan
- with Uwobo_failure errmsg ->
- return_error
- (sprintf "Stylesheet chain application failed: %s" errmsg)
- outchan)
+ if Unix.fork () = 0 then
+ (let logger = new Uwobo_logger.processingLogger () in
+ let xmluri = req#param "xmluri" in
+ let keys = Pcre.split ~pat:"," (req#param "keys") in
+ (* notation: "local" parameters are those defined on a per-stylesheet
+ pasis (i.e. param.key.param=value), "global" parameters are those
+ defined for all stylesheets (i.e. param.param=value) *)
+ let (params, props) = parse_apply_params req#params in
+ syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
+ let domImpl = Gdome.domImplementation () in
+ let input = domImpl#createDocumentFromURI ~uri:xmluri () in
+ syslogger#log `Debug "Applying stylesheet chain ...";
+ try
+ let (write_result, media_type, encoding) = (* out_channel -> unit *)
+ Uwobo_engine.apply
+ ~logger:syslogger ~styles ~keys ~input ~params ~props
+ in
+ let content_type = (* value of Content-Type HTTP response header *)
+ sprintf
+ "%s; charset=%s"
+ (match media_type with None -> default_media_type | Some t -> t)
+ (match encoding with None -> default_encoding | Some e -> e)
+ in
+ syslogger#log
+ `Debug
+ (sprintf
+ "sending output to client (Content-Type: %s)...."
+ content_type);
+ Http_daemon.send_basic_headers ~code:200 outchan;
+ Http_daemon.send_header "Content-Type" content_type outchan;
+ Http_daemon.send_CRLF outchan;
+ write_result outchan
+ with Uwobo_failure errmsg ->
+ return_error
+ (sprintf "Stylesheet chain application failed: %s" errmsg)
+ outchan)
| "/help" -> Http_daemon.respond ~body:usage_string outchan
| invalid_request ->
Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
with
- | Http_request.Param_not_found attr_name ->
+ | Http_types.Param_not_found attr_name ->
bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
| exc ->
Http_daemon.respond
@@ -197,6 +261,7 @@ syslogger#log
`Notice
(sprintf "%s started and listening on port %d" daemon_name port);
syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
+Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *)
Http_daemon.start' ~port ~mode:`Thread callback;
syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)