From de72c4ad2f799cfb2a2e23fadc14235a6e1c76e8 Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Fri, 29 Nov 2002 16:18:00 +0000 Subject: [PATCH] snapshot Fri, 29 Nov 2002 17:17:46 +0100 zack --- helm/uwobo/src/ocaml/uwobo.ml | 56 ++++++------- helm/uwobo/src/ocaml/uwobo_engine.ml | 109 +++++++++++++++++++++++--- helm/uwobo/src/ocaml/uwobo_engine.mli | 6 +- helm/uwobo/src/ocaml/uwobo_styles.ml | 24 ++++-- helm/uwobo/src/ocaml/uwobo_styles.mli | 4 +- 5 files changed, 146 insertions(+), 53 deletions(-) diff --git a/helm/uwobo/src/ocaml/uwobo.ml b/helm/uwobo/src/ocaml/uwobo.ml index 4584e0910..fef1c0d91 100644 --- a/helm/uwobo/src/ocaml/uwobo.ml +++ b/helm/uwobo/src/ocaml/uwobo.ml @@ -38,6 +38,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/xml";; +let default_encoding = "utf8";; let port = try int_of_string (Sys.getenv port_env_var) @@ -50,9 +52,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 *) @@ -117,7 +118,7 @@ let callback req outchan = | "/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 @@ -147,7 +148,6 @@ let callback req outchan = 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 @@ -160,32 +160,26 @@ let callback req outchan = 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) diff --git a/helm/uwobo/src/ocaml/uwobo_engine.ml b/helm/uwobo/src/ocaml/uwobo_engine.ml index bda9b1804..66a6ca7ce 100644 --- a/helm/uwobo/src/ocaml/uwobo_engine.ml +++ b/helm/uwobo/src/ocaml/uwobo_engine.ml @@ -27,6 +27,21 @@ 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
@@ -52,23 +67,91 @@ Props: %s
", " (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 *) diff --git a/helm/uwobo/src/ocaml/uwobo_engine.mli b/helm/uwobo/src/ocaml/uwobo_engine.mli index bf18e6308..ae47ccad0 100644 --- a/helm/uwobo/src/ocaml/uwobo_engine.mli +++ b/helm/uwobo/src/ocaml/uwobo_engine.mli @@ -32,6 +32,10 @@ @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 -> @@ -40,5 +44,5 @@ val apply: params: (string -> (string * string) list) -> props: (string * string) list -> input: Gdome.document -> - Gdome.document + (out_channel -> unit) * string option * string option diff --git a/helm/uwobo/src/ocaml/uwobo_styles.ml b/helm/uwobo/src/ocaml/uwobo_styles.ml index 93fdb8e63..b40298780 100644 --- a/helm/uwobo/src/ocaml/uwobo_styles.ml +++ b/helm/uwobo/src/ocaml/uwobo_styles.ml @@ -40,16 +40,26 @@ class styles = 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 = diff --git a/helm/uwobo/src/ocaml/uwobo_styles.mli b/helm/uwobo/src/ocaml/uwobo_styles.mli index a8b3c947b..0ff5f1fb5 100644 --- a/helm/uwobo/src/ocaml/uwobo_styles.mli +++ b/helm/uwobo/src/ocaml/uwobo_styles.mli @@ -29,12 +29,14 @@ exception Stylesheet_already_in of string;; 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 -- 2.39.2