*)
open Printf;;
+open Uwobo_common;;
(* debugging settings *)
let debug = true;;
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 *)
(* 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
try
syslogger#log `Debug (sprintf "Received request: %s" req#path);
(match req#path with
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
- let keys =
- try
- Pcre.split ~pat:"," (req#param "keys")
- with Http_request.Param_not_found _ -> []
- in
- (match 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
- let keys =
- try
- Pcre.split ~pat:"," (req#param "keys")
- with Http_request.Param_not_found _ -> []
- in
- (match 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
((fun _ -> []), []) (* no parameters, no properties *)
req#params
in
- Uwobo_engine.apply
- ~logger ~styles ~keys ~input:xmluri ~params ~props outchan)
+ syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
+ let input = styles#domImpl#createDocumentFromURI ~uri:xmluri () in
+ let output =
+ Uwobo_engine.apply ~logger ~styles ~keys ~input ~params ~props
+ (* TODO uhm ... what to do if Uwobo_failure is raised? *)
+ in
+ syslogger#log `Debug logger#asText;
+ let tempfile = (* temporary file on which save XML output *)
+ (* TODO I don't need a tempfile, but gdome seems not to permit to
+ return the string representation of a Gdome.document *)
+ let inchan = Unix.open_process_in "tempfile --prefix=uwobo" in
+ let name = input_line inchan in
+ close_in inchan;
+ name
+ in
+ syslogger#log
+ `Debug
+ (sprintf "saving output document to %s ..." tempfile);
+ let res =
+ styles#domImpl#saveDocumentToFile ~doc:output ~name:tempfile ()
+ in
+ if not res then
+ raise (Uwobo_failure ("unable to save output to file " ^ tempfile));
+ syslogger#log `Debug "sending output to client ....";
+ Http_daemon.send_basic_headers ~code:200 outchan;
+ (* TODO set Content-Type *)
+ Http_daemon.send_CRLF outchan;
+ Http_daemon.send_file ~name:tempfile outchan;
+ Unix.unlink tempfile)
| "/help" -> Http_daemon.respond ~body:usage_string outchan
| invalid_request ->
Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
projects / helm.git / blobdiff