let daemon_name = "UWOBO OCaml";;
let default_port = 8082;;
let port_env_var = "UWOBO_PORT";;
+let default_media_type = "text/xml";;
+let default_encoding = "utf8";;
let port =
try
int_of_string (Sys.getenv port_env_var)
(* facilities *)
let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" 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 *)
| "/add" ->
(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
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 domImpl = Gdome.domImplementation () in
let input = domImpl#createDocumentFromURI ~uri:xmluri () in
syslogger#log `Debug "Applying stylesheet chain ...";
- let output =
- Uwobo_engine.apply
- ~logger:syslogger ~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 = 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)
+ 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)
| "/help" -> Http_daemon.respond ~body:usage_string outchan
| invalid_request ->
Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
open Printf;;
open Uwobo_common;;
+exception Unsupported_property of string;;
+
+let supported_properties = [
+ "cdata-section-elements";
+ "doctype-public";
+ "doctype-system";
+ "encoding";
+ "indent";
+ "media-type";
+ "method";
+ "omit-xml-declaration";
+ "standalone";
+ "version"
+]
+
let dump_args keys params props =
(sprintf "
Keys: %s<br />
", "
(List.map (fun (key,value) -> sprintf "%s:%s" key value) props)))
- (* TODO add global mutex, stylesheets are freezed at the request moment *)
+let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
+let outputS = Gdome.domString "output"
+let q_outputS = Gdome.domString "xsl:output"
+let is_supported_property name = List.mem name supported_properties
+
+ (** set a list of output properties in an xslt stylesheet, return a copy of
+ the given stylesheet modified as needed, given stylesheet wont be changed by
+ this operation *)
+let apply_properties logger last_stylesheet props =
+ let last_stylesheet =
+ new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
+ in
+ let output_element =
+ let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
+ (match node_list#item 0 with
+ | None -> (* no xsl:output element, create it from scratch *)
+ logger#log `Debug "Creating xsl:output node ...";
+ let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
+ let root = last_stylesheet#get_documentElement in
+ ignore (root#insertBefore (elt :> Gdome.node) root#get_firstChild);
+ elt
+ | Some node -> new Gdome.element_of_node node)
+ in
+ let apply_property (name, value) =
+ if is_supported_property name then begin
+ logger#log `Debug (sprintf "Setting property: %s = %s" name value);
+ output_element#setAttribute
+ (Gdome.domString name)
+ (Gdome.domString value)
+ end
+ else
+ raise (Unsupported_property name)
+ in
+ List.iter apply_property props;
+ last_stylesheet
+
+ (** given a Gdome.document representing an XSLT stylesheet and an output
+ property return 'Some value' where 'value' is the property value, or None if
+ it's not defined *)
+let get_property name (document: Gdome.document) =
+ let node_list = document#getElementsByTagNameNS xslNS outputS in
+ match node_list#item 0 with
+ | None -> None
+ | Some node ->
+ let element = new Gdome.element_of_node node in
+ let domName = Gdome.domString name in
+ if element#hasAttribute domName then
+ Some (element#getAttribute domName)#to_string
+ else
+ None
+
let apply
~(logger: Uwobo_logger.sysLogger)
~(styles: Uwobo_styles.styles)
~keys ~params ~props ~input =
- let stylesheets = styles#get keys in
+ (* "p_" prefix means "processed" *)
+ let (p_stylesheets, last_stylesheet) = styles#get keys in
logger#log `Debug (dump_args keys params props);
logger#log `Debug "Creating input document ...";
- List.fold_left
- (fun source (key, stylesheet) ->
- logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
- try
- let params =
- List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
- in
- Gdome_xslt.applyStylesheet ~source ~stylesheet ~params
- with e -> raise (Uwobo_failure (Printexc.to_string e)))
- input
- stylesheets
+ let result = (* Gdome.document *)
+ List.fold_left
+ (fun source (key, stylesheet) ->
+ logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
+ try
+ let params =
+ List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
+ in
+ Gdome_xslt.applyStylesheet ~source ~stylesheet ~params
+ with e -> raise (Uwobo_failure (Printexc.to_string e)))
+ input
+ p_stylesheets
+ in
+ (* used to retrieve serialization options *)
+ let last_stylesheet =
+ try
+ apply_properties logger last_stylesheet props
+ with Unsupported_property prop ->
+ raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
+ in
+ let p_last_stylesheet = Gdome_xslt.processStylesheet last_stylesheet in
+ ((fun outchan -> (* serialization function *)
+ Gdome_xslt.saveResultToChannel
+ ~outchan
+ ~result
+ ~stylesheet:p_last_stylesheet),
+ (get_property "media-type" last_stylesheet), (* media-type *)
+ (get_property "encoding" last_stylesheet)) (* encoding *)
@param props xml:output properties
@param input URI of input document
@param channel on which write final output
+ @return a triple: 1st element is a function that takes an out_channel and
+ write the result document on it, 2nd element is a string option representing
+ the desired media-type, 3rd is a string option representing the desired
+ encoding
*)
val apply:
logger: Uwobo_logger.sysLogger ->
params: (string -> (string * string) list) ->
props: (string * string) list ->
input: Gdome.document ->
- Gdome.document
+ (out_channel -> unit) * string option * string option
val domImpl = Gdome.domImplementation ()
(** process an XSLT stylesheet *)
- method private process uri =
- Gdome_xslt.processStylesheet (domImpl#createDocumentFromURI ~uri ())
+ method private process uri = domImpl#createDocumentFromURI ~uri ()
method get keys =
self#doReader (lazy (
- List.fold_left
- (fun collected_styles key ->
- (List.find (fun (k, _) -> k = key) stylesheets)::collected_styles)
- []
- (List.rev keys)
+ let rev_keys = List.rev keys in
+ let last_key = List.hd rev_keys in
+ let p_stylesheets =
+ List.fold_left
+ (fun collected_styles key ->
+ let (key, stylesheet) =
+ List.find (fun (k, _) -> k = key) stylesheets
+ in
+ (key, Gdome_xslt.processStylesheet stylesheet)::collected_styles)
+ []
+ rev_keys
+ in
+ let last_stylesheet =
+ snd (List.find (fun (k, _) -> k = last_key) stylesheets)
+ in
+ (p_stylesheets, last_stylesheet)
))
method add key uri =
class styles:
object
- method get: string list -> (string * I_gdome_xslt.processed_stylesheet) list
method add: string -> string -> unit
method remove: string -> unit
method removeAll: unit
method list: string list
method reload: string -> unit
method reloadAll: unit
+ method get:
+ string list ->
+ (string * I_gdome_xslt.processed_stylesheet) list * Gdome.document
end
projects / helm.git / commitdiff