X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fsrc%2Focaml%2Fuwobo.ml;h=142fddd7d1da846cde9dff35270de816001df36f;hb=2a5683cf113dc524f685af57cf7ae2dda3190467;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..142fddd7d 100644 --- a/helm/uwobo/src/ocaml/uwobo.ml +++ b/helm/uwobo/src/ocaml/uwobo.ml @@ -25,6 +25,7 @@ *) open Printf;; +open Uwobo_common;; (* debugging settings *) let debug = true;; @@ -60,16 +61,38 @@ 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 *) (* 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 | "/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 else begin @@ -80,82 +103,27 @@ 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 @@ -163,49 +131,60 @@ let callback req outchan = (* 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 *) + 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 (params, props) = + 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 *) + req#params 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 + 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 - 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) + 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 - let add_property name value = - properties := - (Pcre.replace ~pat:"^prop\\." name, value) :: !properties + syslogger#log + `Debug + (sprintf "saving output document to %s ..." tempfile); + let res = + styles#domImpl#saveDocumentToFile ~doc:output ~name:tempfile () 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 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) @@ -221,8 +200,8 @@ 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 ())); 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)