X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fsrc%2Focaml%2Fuwobo.ml;h=22714b29a837b6ba18bcb3edb144a5b3b2590568;hb=b1fb6b8e1767d775bc452303629e95941d142bea;hp=2ecf95518e9d77c841ebbb43e770012b080c5c47;hpb=38d9fb165745652a56f92d48ab3b02153e5a187a;p=helm.git
diff --git a/helm/uwobo/src/ocaml/uwobo.ml b/helm/uwobo/src/ocaml/uwobo.ml
index 2ecf95518..22714b29a 100644
--- a/helm/uwobo/src/ocaml/uwobo.ml
+++ b/helm/uwobo/src/ocaml/uwobo.ml
@@ -24,7 +24,11 @@
* http://cs.unibo.it/helm/.
*)
+(* TODO braindead situation: /add of a stylesheet which uri is an uwobo
+invocation *)
+
open Printf;;
+open Uwobo_common;;
(* debugging settings *)
let debug = true;;
@@ -37,6 +41,8 @@ Http_common.debug := http_debug;;
let daemon_name = "UWOBO OCaml";;
let default_port = 8082;;
let port_env_var = "UWOBO_PORT";;
+let default_media_type = "text/html";;
+let default_encoding = "utf8";;
let port =
try
int_of_string (Sys.getenv port_env_var)
@@ -49,9 +55,8 @@ in
(* facilities *)
let pp_error = sprintf "Error: %s
" in
-let invocation_error msg outchan =
- (* return an ok (200) http response, which display in html an invocation error
- message *)
+let return_error msg outchan =
+ (* return an ok (200) http response, which display in html an error message *)
Http_daemon.respond ~body:(pp_error msg) outchan
in
let bad_request body outchan = (* return a bad request http response *)
@@ -60,18 +65,118 @@ in
(* values common to all threads *)
let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
+syslogger#enable;
let styles = new Uwobo_styles.styles in
-let styles_mutex = Mutex.create () 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 =
+ (* perform an 'action' that can be applied to a list of keys or, if no
+ keys was given, to all keys *)
+ let act_on_keys req styles outchan per_key_action all_keys_action logmsg =
+ let log = new Uwobo_logger.processingLogger () in
+ let keys =
+ try
+ Pcre.split ~pat:"," (req#param "keys")
+ with Http_request.Param_not_found _ -> []
+ in
+ (match keys with
+ | [] -> (* no key provided, act on all stylesheets *)
+ log#log "reloading all stylesheets ...";
+ (try all_keys_action () with e -> log#log (Printexc.to_string e))
+ | keys ->
+ List.iter
+ (fun key -> (* act on a single stylesheet *)
+ log#log (sprintf "%s stylesheet %s" logmsg key);
+ (try per_key_action key with e -> log#log (Printexc.to_string e)))
+ keys);
+ Http_daemon.respond ~body:log#asHtml outchan
+ in
+ let parse_apply_params = (* parse parameters for '/apply' action *)
+ let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
+ let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
+ let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
+ List.fold_left
+ (fun (old_params, old_properties) (name, value) ->
+ match name with
+ | name when is_global_param name ->
+ let name = Pcre.replace ~pat:"^param\\." name in
+ ((fun x -> (old_params x) @ [name, value]), old_properties)
+ | name when is_local_param name ->
+ let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
+ let (key, name) = (pieces.(1), pieces.(2)) in
+ ((function
+ | x when x = key -> [name, value] @ (old_params x)
+ | x -> old_params x),
+ old_properties)
+ | name when is_property name ->
+ let name = Pcre.replace ~pat:"^prop\\." name in
+ (old_params, ((name, value) :: old_properties))
+ | _ -> (old_params, old_properties))
+ ((fun _ -> []), []) (* no parameters, no properties *)
+ in
try
+ syslogger#log `Debug (sprintf "Received request: %s" req#path);
(match req#path with
| "/add" ->
- (let bindings = req#param_all "bind" in
+ (let bindings = req#paramAll "bind" in
if bindings = [] then
- invocation_error "No [key,stylesheet] binding provided" outchan
+ return_error "No [key,stylesheet] binding provided" outchan
else begin
let log = new Uwobo_logger.processingLogger () in
List.iter
@@ -80,132 +185,64 @@ let callback req outchan =
match pieces with
| [key; style] ->
log#log (sprintf "adding binding <%s,%s>" key style);
- Mutex.lock styles_mutex;
(try
styles#add key style;
with e ->
- log#log
- (sprintf
- "failure while adding <%s,%s>: exception %s"
- key style (Printexc.to_string e)));
- Mutex.unlock styles_mutex
+ log#log (Printexc.to_string e))
| _ -> log#log (sprintf "invalid binding %s" binding))
bindings;
Http_daemon.respond ~body:log#asHtml outchan
end)
- | "/remove" -> (* TODO this branch is almost identical to "/reload" one *)
- (let log = new Uwobo_logger.processingLogger () in
- (match (Pcre.split ~pat:"," (req#param "keys")) with
- | [] -> (* no key provided, unload all stylesheets *)
- log#log "removing all stylesheets ...";
- Mutex.lock styles_mutex;
- (try
- styles#removeAll
- with e ->
- log#log
- (sprintf
- "failure while removing all stylesheets: exception %s"
- (Printexc.to_string e)));
- Mutex.unlock styles_mutex
- | keys ->
- List.iter
- (fun key -> (* remove a single stylesheet *)
- Mutex.lock styles_mutex;
- log#log (sprintf "removing stylesheet %s" key);
- (try
- styles#remove key
- with e ->
- log#log
- (sprintf
- "failure while removing stylesheet %s: exception %s"
- key (Printexc.to_string e)));
- Mutex.unlock styles_mutex)
- keys);
- Http_daemon.respond ~body:log#asHtml outchan)
| "/list" ->
(let log = new Uwobo_logger.processingLogger () in
log#log "Stylesheet list:";
- styles#iterKeys (fun k -> log#log (styles#getInfo k));
- Http_daemon.respond ~body:log#asHtml outchan)
- | "/reload" -> (* TODO this branch is almost identical to "/remove" one *)
- (let log = new Uwobo_logger.processingLogger () in
- (match (Pcre.split ~pat:"," (req#param "keys")) with
- | [] -> (* no key provided, reload all stylesheets *)
- log#log "reloading all stylesheets ...";
- Mutex.lock styles_mutex;
- (try
- styles#reloadAll
- with e ->
- log#log
- (sprintf
- "failure while reloading all stylesheets: exception %s"
- (Printexc.to_string e)));
- Mutex.unlock styles_mutex
- | keys ->
- List.iter
- (fun key -> (* reload a single stylesheet *)
- Mutex.lock styles_mutex;
- log#log (sprintf "reloading stylesheet %s" key);
- (try
- styles#reload key
- with e ->
- log#log
- (sprintf
- "failure while reloading stylesheet %s: exception %s"
- key (Printexc.to_string e)));
- Mutex.unlock styles_mutex)
- keys);
+ List.iter (fun s -> log#log s) styles#list;
Http_daemon.respond ~body:log#asHtml outchan)
+ | "/remove" ->
+ act_on_keys
+ req styles outchan
+ styles#remove (fun () -> styles#removeAll) "removing"
+ | "/reload" ->
+ act_on_keys
+ 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 local_params = ref [] in (* association list *)
- let global_params = ref [] in (* association list *)
- let properties = ref [] in (* association list *)
- let get_style_param key name =
- let params = (* try local params and fallback on global params *)
- try List.assoc key !local_params with Not_found -> global_params
- in
- List.assoc name !params (* may raise Not_found *)
- in
- let get_property name = List.assoc name !properties in
- let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}" x in
- let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}" x in
- let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+" x in
- let add_global_param name value =
- let name = Pcre.replace ~pat:"^param\\." name in
- global_params := (name, value) :: !global_params
- in
- let add_local_param name value =
- let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
- let (key, param) = (pieces.(1), pieces.(2)) in
- (try
- let previous_params = List.assoc key !local_params in
- let new_params = (param, value) :: previous_params in
- local_params := new_params :: (List.remove_assoc key !local_params)
- with Not_found -> (* first local parameter for 'key' *)
- local_params := [(param, value)] :: !local_params)
- in
- let add_property name value =
- properties :=
- (Pcre.replace ~pat:"^prop\\." name, value) :: !properties
- in
- List.iter
- (fun (name, value) ->
- match name with
- | name when is_global_param name -> add_global_param name value
- | name when is_local_param name -> add_local_param name value
- | name when is_property name -> add_property name value
- | _ -> ())
- req#params;
- Uwobo_engine.apply
- ~logger ~styles ~keys ~input:xmluri
- ~params:get_style_param ~props:get_property
- 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)
@@ -221,8 +258,9 @@ in
(* daemon initialization *)
syslogger#log
`Notice
- (sprintf "%s started and listening on port %d\n" daemon_name port);
-syslogger#log `Notice (sprintf "current directory is %s\n" (Sys.getcwd ()));
+ (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!\n" daemon_name)
+syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)