From: Stefano Zacchiroli Date: Wed, 12 Mar 2003 18:37:49 +0000 (+0000) Subject: moved uwobo sources to the root uwobo directory X-Git-Tag: V_0_0_4_2~11 X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=commitdiff_plain;h=47b0c2c1b421b62302b1957954912b4c0dfba9fa moved uwobo sources to the root uwobo directory --- diff --git a/helm/uwobo/.depend b/helm/uwobo/.depend new file mode 100644 index 000000000..96ae180f4 --- /dev/null +++ b/helm/uwobo/.depend @@ -0,0 +1,15 @@ +uwobo.cmo: uwobo_common.cmi uwobo_engine.cmi uwobo_logger.cmi \ + uwobo_styles.cmi +uwobo.cmx: uwobo_common.cmx uwobo_engine.cmx uwobo_logger.cmx \ + uwobo_styles.cmx +uwobo_common.cmo: uwobo_common.cmi +uwobo_common.cmx: uwobo_common.cmi +uwobo_engine.cmo: uwobo_common.cmi uwobo_logger.cmi uwobo_styles.cmi \ + uwobo_engine.cmi +uwobo_engine.cmx: uwobo_common.cmx uwobo_logger.cmx uwobo_styles.cmx \ + uwobo_engine.cmi +uwobo_logger.cmo: uwobo_logger.cmi +uwobo_logger.cmx: uwobo_logger.cmi +uwobo_styles.cmo: uwobo_styles.cmi +uwobo_styles.cmx: uwobo_styles.cmi +uwobo_engine.cmi: uwobo_logger.cmi uwobo_styles.cmi diff --git a/helm/uwobo/Makefile b/helm/uwobo/Makefile new file mode 100644 index 000000000..c586dba2c --- /dev/null +++ b/helm/uwobo/Makefile @@ -0,0 +1,62 @@ +VERSION = 0.0.1 +DISTDIR = uwobo-$(VERSION) +REQUIRES = http gdome2 gdome2-xslt pcre unix +COMMONOPTS = -package "$(REQUIRES)" -pp camlp4o +OCAMLFIND = ocamlfind +OCAMLC = $(OCAMLFIND) ocamlc $(COMMONOPTS) +OCAMLOPT = $(OCAMLFIND) ocamlopt $(COMMONOPTS) +OCAMLDEP = $(OCAMLFIND) ocamldep $(COMMONOPTS) +OCAMLDOC = \ + ocamldoc \ + $(shell $(OCAMLFIND) query -i-format http) \ + $(shell $(OCAMLFIND) query -i-format gdome2) \ + $(shell $(OCAMLFIND) query -i-format gdome2-xslt) \ + $(shell $(OCAMLFIND) query -i-format pcre) \ + $(shell $(OCAMLFIND) query -i-format unix) +MODULES = uwobo_common uwobo_styles uwobo_logger uwobo_engine +OBJS = $(patsubst %,%.cmo,$(MODULES)) +OBJSOPT = $(patsubst %,%.cmx,$(MODULES)) + +all: byte +byte: uwobo +opt: uwobo.opt +world: byte opt + +include .depend +depend: + $(OCAMLDEP) *.ml *.mli > .depend + +%.cmi: %.mli + $(OCAMLC) -c $< +%.cmo: %.ml %.cmi + $(OCAMLC) -c $< +%.cmx: %.ml %.cmi + $(OCAMLOPT) -c $< +uwobo.cmo: uwobo.ml + $(OCAMLC) -c $< +uwobo.cmx: uwobo.ml + $(OCAMLOPT) -c $< +uwobo: $(OBJS) uwobo.ml + $(OCAMLC) -linkpkg -o $@ $^ +uwobo.opt: $(OBJSOPT) uwobo.ml + $(OCAMLOPT) -linkpkg -o $@ $^ + +uwobo.dot: *.ml *.mli + $(OCAMLDOC) -dot -o $@ $^ + +distclean: clean +clean: + rm -f *.cm[aiox] *.o uwobo{,.opt,.dot} +dist: distclean depend + mkdir $(DISTDIR)/ + cp \ + $(patsubst %, %.ml, $(MODULES)) \ + $(patsubst %, %.mli, $(MODULES)) \ + uwobo.ml \ + Makefile .depend \ + $(DISTDIR)/ + tar cvzf $(DISTDIR).tar.gz $(DISTDIR)/ + rm -rf $(DISTDIR)/ + +.PHONY: all byte opt world depend clean + diff --git a/helm/uwobo/src/ocaml/.cvsignore b/helm/uwobo/src/ocaml/.cvsignore deleted file mode 100644 index 7a77a0ecd..000000000 --- a/helm/uwobo/src/ocaml/.cvsignore +++ /dev/null @@ -1,7 +0,0 @@ -*.cmi -*.cmo -*.cmx -*.cma -*.cmxa -uwobo -uwobo.opt diff --git a/helm/uwobo/src/ocaml/.depend b/helm/uwobo/src/ocaml/.depend deleted file mode 100644 index 96ae180f4..000000000 --- a/helm/uwobo/src/ocaml/.depend +++ /dev/null @@ -1,15 +0,0 @@ -uwobo.cmo: uwobo_common.cmi uwobo_engine.cmi uwobo_logger.cmi \ - uwobo_styles.cmi -uwobo.cmx: uwobo_common.cmx uwobo_engine.cmx uwobo_logger.cmx \ - uwobo_styles.cmx -uwobo_common.cmo: uwobo_common.cmi -uwobo_common.cmx: uwobo_common.cmi -uwobo_engine.cmo: uwobo_common.cmi uwobo_logger.cmi uwobo_styles.cmi \ - uwobo_engine.cmi -uwobo_engine.cmx: uwobo_common.cmx uwobo_logger.cmx uwobo_styles.cmx \ - uwobo_engine.cmi -uwobo_logger.cmo: uwobo_logger.cmi -uwobo_logger.cmx: uwobo_logger.cmi -uwobo_styles.cmo: uwobo_styles.cmi -uwobo_styles.cmx: uwobo_styles.cmi -uwobo_engine.cmi: uwobo_logger.cmi uwobo_styles.cmi diff --git a/helm/uwobo/src/ocaml/Makefile b/helm/uwobo/src/ocaml/Makefile deleted file mode 100644 index c586dba2c..000000000 --- a/helm/uwobo/src/ocaml/Makefile +++ /dev/null @@ -1,62 +0,0 @@ -VERSION = 0.0.1 -DISTDIR = uwobo-$(VERSION) -REQUIRES = http gdome2 gdome2-xslt pcre unix -COMMONOPTS = -package "$(REQUIRES)" -pp camlp4o -OCAMLFIND = ocamlfind -OCAMLC = $(OCAMLFIND) ocamlc $(COMMONOPTS) -OCAMLOPT = $(OCAMLFIND) ocamlopt $(COMMONOPTS) -OCAMLDEP = $(OCAMLFIND) ocamldep $(COMMONOPTS) -OCAMLDOC = \ - ocamldoc \ - $(shell $(OCAMLFIND) query -i-format http) \ - $(shell $(OCAMLFIND) query -i-format gdome2) \ - $(shell $(OCAMLFIND) query -i-format gdome2-xslt) \ - $(shell $(OCAMLFIND) query -i-format pcre) \ - $(shell $(OCAMLFIND) query -i-format unix) -MODULES = uwobo_common uwobo_styles uwobo_logger uwobo_engine -OBJS = $(patsubst %,%.cmo,$(MODULES)) -OBJSOPT = $(patsubst %,%.cmx,$(MODULES)) - -all: byte -byte: uwobo -opt: uwobo.opt -world: byte opt - -include .depend -depend: - $(OCAMLDEP) *.ml *.mli > .depend - -%.cmi: %.mli - $(OCAMLC) -c $< -%.cmo: %.ml %.cmi - $(OCAMLC) -c $< -%.cmx: %.ml %.cmi - $(OCAMLOPT) -c $< -uwobo.cmo: uwobo.ml - $(OCAMLC) -c $< -uwobo.cmx: uwobo.ml - $(OCAMLOPT) -c $< -uwobo: $(OBJS) uwobo.ml - $(OCAMLC) -linkpkg -o $@ $^ -uwobo.opt: $(OBJSOPT) uwobo.ml - $(OCAMLOPT) -linkpkg -o $@ $^ - -uwobo.dot: *.ml *.mli - $(OCAMLDOC) -dot -o $@ $^ - -distclean: clean -clean: - rm -f *.cm[aiox] *.o uwobo{,.opt,.dot} -dist: distclean depend - mkdir $(DISTDIR)/ - cp \ - $(patsubst %, %.ml, $(MODULES)) \ - $(patsubst %, %.mli, $(MODULES)) \ - uwobo.ml \ - Makefile .depend \ - $(DISTDIR)/ - tar cvzf $(DISTDIR).tar.gz $(DISTDIR)/ - rm -rf $(DISTDIR)/ - -.PHONY: all byte opt world depend clean - diff --git a/helm/uwobo/src/ocaml/uwobo.ml b/helm/uwobo/src/ocaml/uwobo.ml deleted file mode 100644 index 741b8d20f..000000000 --- a/helm/uwobo/src/ocaml/uwobo.ml +++ /dev/null @@ -1,344 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -open Printf;; -open Uwobo_common;; - - (* debugging settings *) -let debug = false;; -let debug_level = `Notice;; -let debug_print s = if debug then prerr_endline s;; -Http_common.debug := false;; -let logfile = Some "uwobo.log";; (* relative to execution dir *) -let logfile_perm = 0o640;; - - (* other settings *) -let daemon_name = "UWOBO OCaml";; -let default_port = 58080;; -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) - with - | Not_found -> default_port - | Failure "int_of_string" -> - prerr_endline "Warning: invalid port, reverting to default"; - default_port;; - - (** 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 keys_param styles outchan per_key_action all_keys_action logmsg -= - let log = new Uwobo_logger.processingLogger () in - let keys = - try - Pcre.split ~pat:"," keys_param - with Http_types.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); - output_string outchan log#asHtml; - flush outchan -;; - - (** parse parameters for '/apply' action *) -let parse_apply_params = - 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 *) -;; - - (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer - on ~res_pipe (with a timeout of 60 seconds) and send over outchan data - received from ~res_pipe *) -let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan = - debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); - output_string cmd_pipe (cmd ^ "\n"); (* send command to grandfather *) - flush cmd_pipe; - let res_pipe_fd = Unix.descr_of_in_channel res_pipe in - let (read_fds, _, _) = (* wait for an answer *) - Unix.select [res_pipe_fd] [] [] 60.0 - in - (match read_fds with - | [fd] when fd = res_pipe_fd -> (* send answer to http client *) - Http_daemon.send_basic_headers ~code:200 outchan; - Http_daemon.send_CRLF outchan; - (try - while true do - output_string outchan ((input_line res_pipe) ^ "\n") - done - with End_of_file -> flush outchan) - | _ -> (* no answer received from grandfather *) - return_error "Timeout!" outchan) -;; - -let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE) = - (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ") -;; - -exception Restart_HTTP_daemon;; - - (* reuquest handler action - @param syslogger Uwobo_logger.sysLogger instance used for logginf - @param styles Uwobo_styles.styles instance which keeps the stylesheets list - @param cmd_pipe output _channel_ used to _write_ update messages - @param res_pipe input _channel_ used to _read_ grandparent results - @param req http request instance - @param outchan output channel connected to http client - *) -let callback - ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan - = - try - syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr); - syslogger#log `Debug (sprintf "Received request: %s" req#path); - (match req#path with - | "/add" -> - (let bindings = req#paramAll "bind" in - if bindings = [] then - return_error "No [key,stylesheet] binding provided" outchan - else begin - let cmd = sprintf "add %s" (String.concat ";" bindings) in - short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan - end) - | "/remove" -> - let cmd = sprintf "remove %s" (req#param "keys") in - short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan - | "/reload" -> - let cmd = sprintf "reload %s" (req#param "keys") in - short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan - | "/list" -> - (let log = new Uwobo_logger.processingLogger () in - log#log "Stylesheet list:"; - List.iter (fun s -> log#log s) styles#list; - Http_daemon.respond ~body:log#asHtml outchan) - | "/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 (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 *) - let res = Uwobo_engine.apply - ~logger:syslogger ~styles ~keys ~input ~params ~props in - res - 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); - syslogger#log `Debug (sprintf "%s done!" req#path); - with - | Http_types.Param_not_found attr_name -> - bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan - | exc -> - return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan -in - - (* UWOBO's startup *) -let main () = - (* (1) system logger *) - let logger_outchan = - match logfile with - | None -> stderr - | Some f -> - open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm f - in - let syslogger = - new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan () - in - syslogger#enable; - (* (2) stylesheets list *) - let styles = new Uwobo_styles.styles in - (* (3) clean up actions *) - let last_process = ref true in - let http_child = ref None in - let die_nice () = (** at_exit callback *) - if !last_process then begin - (match !http_child with - | None -> () - | Some pid -> Unix.kill pid Sys.sigterm); - syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name); - syslogger#disable; - close_out logger_outchan - end - in - at_exit die_nice; - ignore (Sys.signal Sys.sigterm - (Sys.Signal_handle (fun _ -> raise Sys.Break))); - syslogger#log `Notice - (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 *) - while true do - let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in - let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in - match Unix.fork () with - | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *) - http_child := Some child; - let stop_http_daemon () = (* kill child *) - debug_print (sprintf "Grandparent: killing pid %d" child); - Unix.kill child Sys.sigterm; (* kill child ... *) - debug_print "Grandparent: waiting for its zombie ..."; - ignore (Unix.waitpid [] child); (* ... and its zombie *) - debug_print "Grandparent: murder completed!!!" - in - Unix.close cmd_pipe_entrance; - Unix.close res_pipe_exit; - let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in - let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in - (try - while true do - (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after - child process has been killed *) - debug_print "Grandparent: waiting for commands ..."; - let cmd = input_line cmd_pipe in - debug_print (sprintf "Grandparent: received %s command" cmd); - (match cmd with (* command from grandchild *) - | "test" -> - debug_print "Grandparent: Hello, world!"; - stop_http_daemon (); - output_string res_pipe "Grandparent: Hello, world!\n"; - flush res_pipe; - raise Restart_HTTP_daemon - | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *) - let bindings = - Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line) - in - stop_http_daemon (); - let log = new Uwobo_logger.processingLogger () in - List.iter - (fun binding -> (* add a binding *) - let pieces = Pcre.split ~pat:"," binding in - match pieces with - | [key; style] -> - log#log (sprintf "adding binding <%s,%s>" key style); - (try - styles#add key style; - with e -> - log#log (Printexc.to_string e)) - | _ -> log#log (sprintf "invalid binding %s" binding)) - bindings; - output_string res_pipe log#asHtml; - flush res_pipe; - raise Restart_HTTP_daemon - | line when Pcre.pmatch ~rex:remove_cmd_RE line -> (* /remove *) - stop_http_daemon (); - let arg = Pcre.replace ~rex:remove_cmd_RE line in - act_on_keys - arg styles res_pipe - styles#remove (fun () -> styles#removeAll) - "removing"; - raise Restart_HTTP_daemon - | line when Pcre.pmatch ~rex:reload_cmd_RE line -> (* /reload *) - stop_http_daemon (); - let arg = Pcre.replace ~rex:reload_cmd_RE line in - act_on_keys - arg styles res_pipe - styles#reload (fun () -> styles#reloadAll) - "reloading"; - raise Restart_HTTP_daemon - | cmd -> (* invalid interprocess command received *) - syslogger#log `Warning - (sprintf "Ignoring invalid interprocess command: '%s'" cmd)) - done - with Restart_HTTP_daemon -> - close_in cmd_pipe; (* these calls close also fds *) - close_out res_pipe;) - | 0 -> (* (5) child: serve http requests *) - Unix.close cmd_pipe_exit; - Unix.close res_pipe_entrance; - last_process := false; - let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in - let res_pipe = Unix.in_channel_of_descr res_pipe_exit in - debug_print "Starting HTTP daemon ..."; - (* next invocation doesn't return, process will keep on serving HTTP - requests until it will get killed by father *) - Http_daemon.start'~port ~mode:`Fork - (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ()) - | _ (* < 0 *) -> (* fork failed :-((( *) - failwith "Can't fork :-(" - done -in - - (* daemon initialization *) -try - Sys.catch_break true; - main () -with Sys.Break -> () (* 'die_nice' registered with at_exit *) - diff --git a/helm/uwobo/src/ocaml/uwobo_common.ml b/helm/uwobo/src/ocaml/uwobo_common.ml deleted file mode 100644 index 7664c93b2..000000000 --- a/helm/uwobo/src/ocaml/uwobo_common.ml +++ /dev/null @@ -1,111 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -open Printf;; - -exception Uwobo_failure of string;; - -let supported_properties = [ - "cdata-section-elements"; - "doctype-public"; - "doctype-system"; - "encoding"; - "indent"; - "media-type"; - "method"; - "omit-xml-declaration"; - "standalone"; - "version" -] - -let is_supported_property name = List.mem name supported_properties - -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,uri[&...]]
- 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[&...]]][&prop.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 ", " supported_properties);; - -let pp_error = sprintf "

Error: %s

";; -let return_error msg outchan = - Http_daemon.respond ~body:(pp_error msg) outchan;; -let bad_request body outchan = - Http_daemon.respond_error ~code:400 ~body outchan -;; - - diff --git a/helm/uwobo/src/ocaml/uwobo_common.mli b/helm/uwobo/src/ocaml/uwobo_common.mli deleted file mode 100644 index d1a1a8f8c..000000000 --- a/helm/uwobo/src/ocaml/uwobo_common.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -exception Uwobo_failure of string - -val supported_properties: string list -val is_supported_property: string -> bool - -val usage_string: string - - (** return an ok (200) http response, which display in html an error message - *) -val return_error: string -> out_channel -> unit - (** return a 400 (bad request) http response *) -val bad_request: string -> out_channel -> unit - diff --git a/helm/uwobo/src/ocaml/uwobo_engine.ml b/helm/uwobo/src/ocaml/uwobo_engine.ml deleted file mode 100644 index aad4f971b..000000000 --- a/helm/uwobo/src/ocaml/uwobo_engine.ml +++ /dev/null @@ -1,140 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -open Printf;; -open Uwobo_common;; - - (** set this to true and uwobo will save transformation's intermediate results - in /tmp/uwobo_intermediate__.xml *) -let save_intermediate_results = false;; - -exception Unsupported_property of string;; - -let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform" -let outputS = Gdome.domString "output" -let q_outputS = Gdome.domString "xsl:output" - -let default_properties = [] (* no default properties *) - - (** apply an output property to an xslt stylesheet *) -let apply_property logger (element: Gdome.element) (name, value) = - if Uwobo_common.is_supported_property name then begin - logger#log `Debug (sprintf "Setting property: %s = %s" name value); - element#setAttribute (Gdome.domString name) (Gdome.domString value) - end else - raise (Unsupported_property name) - - (** 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. - Before applying "props" properties applies a set of default properties as - defined in "default_properties" *) -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#appendChild (elt :> Gdome.node)); - elt - | Some node -> new Gdome.element_of_node node) - in - List.iter - (apply_property logger (output_element :> Gdome.element)) - (default_properties @ 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 - = - (* "p_" prefix means "processed" *) - let (p_stylesheets, last_stylesheet) = styles#get keys in - logger#log `Debug "Creating input document ..."; - let intermediate_results_seqno = ref 0 in - 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 - logger#log `Debug - (sprintf "Gdome_xslt.applyStylesheet params=%s" - (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params))); - let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in - if save_intermediate_results then begin - let domImpl = Gdome.domImplementation () in - ignore - (domImpl#saveDocumentToFile - ~doc:res - ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml" - !intermediate_results_seqno (Unix.getpid())) - ()); - incr intermediate_results_seqno; - end; - res - with e -> raise (Uwobo_failure (Printexc.to_string e))) - input - p_stylesheets - in - let last_stylesheet = (* used to retrieve serialization options *) - 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 deleted file mode 100644 index 0631bdeed..000000000 --- a/helm/uwobo/src/ocaml/uwobo_engine.mli +++ /dev/null @@ -1,50 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - - (** - @param logger logger for processing messages - @param styles stylesheets object - @param keys (ordered) list of stylesheet names to be applied - @param params function mapping stylesheet names to parameters list - @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 -> - styles: Uwobo_styles.styles -> - keys: string list -> - params: (string -> (string * string) list) -> - props: (string * string) list -> - input: Gdome.document -> - (out_channel -> unit) * string option * string option - diff --git a/helm/uwobo/src/ocaml/uwobo_logger.ml b/helm/uwobo/src/ocaml/uwobo_logger.ml deleted file mode 100644 index bbd7e03f1..000000000 --- a/helm/uwobo/src/ocaml/uwobo_logger.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -open Printf;; - -type priority = [ - `Emerg | `Alert | `Crit | `Err | `Warning | `Notice | `Info | `Debug -] - -let int_of_priority = function - | `Emerg -> 0 - | `Alert -> 1 - | `Crit -> 2 - | `Err -> 3 - | `Warning -> 4 - | `Notice -> 5 - | `Info -> 6 - | `Debug -> 7 - -let string_of_priority = function - | `Emerg -> "EMERGENCY" - | `Alert -> "ALERT" - | `Crit -> "CRITICAL" - | `Err -> "ERROR" - | `Warning -> "WARNING" - | `Notice -> "NOTICE" - | `Info -> "INFO" - | `Debug -> "DEBUG" - -class sysLogger ?(level: priority = `Notice) ?(outchan = stderr) () = - object (self) - val level_no = int_of_priority level - val mutable enabled = false - method level = level - method levelNo = level_no - method enable = enabled <- true - method disable = enabled <- false - method log (prio: priority) msg = - let tm = Unix.localtime (Unix.time ()) in - if enabled && (int_of_priority prio <= level_no) then begin - fprintf outchan ("[UWOBO %02d/%02d/%4d %02d:%02d:%02d] %s: %s\n") - tm.Unix.tm_mday (tm.Unix.tm_mon + 1) (tm.Unix.tm_year + 1900) - tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec - (string_of_priority prio) msg; - flush outchan - end - end - - (** non thread safe, a processingLogger is usually instantied locally for each - thread *) -class processingLogger = - let html_escape = Netencoding.Html.encode ~in_enc:`Enc_iso88591 () in - fun () -> - object - val mutable log_lines: string list = [] - method log msg = log_lines <- msg :: log_lines - method asText = String.concat "\n" (List.rev log_lines) - method asHtml = - sprintf - "\n%s\n" - (String.concat "
\n" (List.map html_escape (List.rev log_lines))) - end - diff --git a/helm/uwobo/src/ocaml/uwobo_logger.mli b/helm/uwobo/src/ocaml/uwobo_logger.mli deleted file mode 100644 index b05cdda08..000000000 --- a/helm/uwobo/src/ocaml/uwobo_logger.mli +++ /dev/null @@ -1,67 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -type priority = [ - | `Emerg (* system is unusable *) - | `Alert (* action must be taken immediately *) - | `Crit (* critical conditions *) - | `Err (* error conditions *) - | `Warning (* warning conditions *) - | `Notice (* normal, but significant, condition *) - | `Info (* informational message *) - | `Debug (* debug-level message *) -] - - (** - Warning: logging is disabled by default, you have to invoke #enable method - before being able to log anything. - @param level minimum level of priority that will be reported, msg with - priority less than this will be ignored - @param outchan output channel on which output log messages *) -class sysLogger: - ?level: priority -> ?outchan: out_channel -> - unit -> - object - method level: priority - method levelNo: int - (** enable logging, by default logging is disabled *) - method enable: unit - (** disable logging *) - method disable: unit - (** log a message *) - method log: priority -> string -> unit - end - -class processingLogger: - unit -> - object - method log: string -> unit - method asText: string - method asHtml: string - end - diff --git a/helm/uwobo/src/ocaml/uwobo_styles.ml b/helm/uwobo/src/ocaml/uwobo_styles.ml deleted file mode 100644 index 9f954f63d..000000000 --- a/helm/uwobo/src/ocaml/uwobo_styles.ml +++ /dev/null @@ -1,101 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -open Printf;; - -exception Stylesheet_not_found of string;; -exception Stylesheet_already_in of string;; - -class styles = - object (self) - (* INVARIANT: 'stylesheets' and 'uris' are in sync *) - - val mutable stylesheets = [] - val mutable uris = [] - val domImpl = Gdome.domImplementation () - - (** process an XSLT stylesheet *) - method private process uri = domImpl#createDocumentFromURI ~uri () - - method get 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) = - try - List.find (fun (k, _) -> k = key) stylesheets - with Not_found -> raise (Stylesheet_not_found key) - 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 = - if (List.mem_assoc key uris) then - raise (Stylesheet_already_in key) - else begin - uris <- (key, uri) :: uris; - stylesheets <- (key, self#process uri) :: stylesheets - end - - method remove key = - if not (List.mem_assoc key uris) then - raise (Stylesheet_not_found key) - else begin - uris <- List.remove_assoc key uris; - stylesheets <- List.remove_assoc key stylesheets - end - - method removeAll = uris <- []; stylesheets <- [] - - method list = - List.map - (fun (key, uri) -> - sprintf "key = %s, uri = %s" key (List.assoc key uris)) - uris - - method reload key = - (try - let uri = List.assoc key uris in - stylesheets <- - (key, self#process uri) :: (List.remove_assoc key stylesheets) - with Not_found -> - raise (Stylesheet_not_found key)) - - method reloadAll = - stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris - - end - diff --git a/helm/uwobo/src/ocaml/uwobo_styles.mli b/helm/uwobo/src/ocaml/uwobo_styles.mli deleted file mode 100644 index 5a0722f03..000000000 --- a/helm/uwobo/src/ocaml/uwobo_styles.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -exception Stylesheet_not_found of string;; -exception Stylesheet_already_in of string;; - -class styles: - object - 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 - diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml new file mode 100644 index 000000000..741b8d20f --- /dev/null +++ b/helm/uwobo/uwobo.ml @@ -0,0 +1,344 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +open Printf;; +open Uwobo_common;; + + (* debugging settings *) +let debug = false;; +let debug_level = `Notice;; +let debug_print s = if debug then prerr_endline s;; +Http_common.debug := false;; +let logfile = Some "uwobo.log";; (* relative to execution dir *) +let logfile_perm = 0o640;; + + (* other settings *) +let daemon_name = "UWOBO OCaml";; +let default_port = 58080;; +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) + with + | Not_found -> default_port + | Failure "int_of_string" -> + prerr_endline "Warning: invalid port, reverting to default"; + default_port;; + + (** 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 keys_param styles outchan per_key_action all_keys_action logmsg += + let log = new Uwobo_logger.processingLogger () in + let keys = + try + Pcre.split ~pat:"," keys_param + with Http_types.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); + output_string outchan log#asHtml; + flush outchan +;; + + (** parse parameters for '/apply' action *) +let parse_apply_params = + 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 *) +;; + + (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer + on ~res_pipe (with a timeout of 60 seconds) and send over outchan data + received from ~res_pipe *) +let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan = + debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); + output_string cmd_pipe (cmd ^ "\n"); (* send command to grandfather *) + flush cmd_pipe; + let res_pipe_fd = Unix.descr_of_in_channel res_pipe in + let (read_fds, _, _) = (* wait for an answer *) + Unix.select [res_pipe_fd] [] [] 60.0 + in + (match read_fds with + | [fd] when fd = res_pipe_fd -> (* send answer to http client *) + Http_daemon.send_basic_headers ~code:200 outchan; + Http_daemon.send_CRLF outchan; + (try + while true do + output_string outchan ((input_line res_pipe) ^ "\n") + done + with End_of_file -> flush outchan) + | _ -> (* no answer received from grandfather *) + return_error "Timeout!" outchan) +;; + +let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE) = + (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ") +;; + +exception Restart_HTTP_daemon;; + + (* reuquest handler action + @param syslogger Uwobo_logger.sysLogger instance used for logginf + @param styles Uwobo_styles.styles instance which keeps the stylesheets list + @param cmd_pipe output _channel_ used to _write_ update messages + @param res_pipe input _channel_ used to _read_ grandparent results + @param req http request instance + @param outchan output channel connected to http client + *) +let callback + ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan + = + try + syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr); + syslogger#log `Debug (sprintf "Received request: %s" req#path); + (match req#path with + | "/add" -> + (let bindings = req#paramAll "bind" in + if bindings = [] then + return_error "No [key,stylesheet] binding provided" outchan + else begin + let cmd = sprintf "add %s" (String.concat ";" bindings) in + short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan + end) + | "/remove" -> + let cmd = sprintf "remove %s" (req#param "keys") in + short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan + | "/reload" -> + let cmd = sprintf "reload %s" (req#param "keys") in + short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan + | "/list" -> + (let log = new Uwobo_logger.processingLogger () in + log#log "Stylesheet list:"; + List.iter (fun s -> log#log s) styles#list; + Http_daemon.respond ~body:log#asHtml outchan) + | "/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 (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 *) + let res = Uwobo_engine.apply + ~logger:syslogger ~styles ~keys ~input ~params ~props in + res + 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); + syslogger#log `Debug (sprintf "%s done!" req#path); + with + | Http_types.Param_not_found attr_name -> + bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan + | exc -> + return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan +in + + (* UWOBO's startup *) +let main () = + (* (1) system logger *) + let logger_outchan = + match logfile with + | None -> stderr + | Some f -> + open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm f + in + let syslogger = + new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan () + in + syslogger#enable; + (* (2) stylesheets list *) + let styles = new Uwobo_styles.styles in + (* (3) clean up actions *) + let last_process = ref true in + let http_child = ref None in + let die_nice () = (** at_exit callback *) + if !last_process then begin + (match !http_child with + | None -> () + | Some pid -> Unix.kill pid Sys.sigterm); + syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name); + syslogger#disable; + close_out logger_outchan + end + in + at_exit die_nice; + ignore (Sys.signal Sys.sigterm + (Sys.Signal_handle (fun _ -> raise Sys.Break))); + syslogger#log `Notice + (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 *) + while true do + let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in + let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in + match Unix.fork () with + | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *) + http_child := Some child; + let stop_http_daemon () = (* kill child *) + debug_print (sprintf "Grandparent: killing pid %d" child); + Unix.kill child Sys.sigterm; (* kill child ... *) + debug_print "Grandparent: waiting for its zombie ..."; + ignore (Unix.waitpid [] child); (* ... and its zombie *) + debug_print "Grandparent: murder completed!!!" + in + Unix.close cmd_pipe_entrance; + Unix.close res_pipe_exit; + let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in + let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in + (try + while true do + (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after + child process has been killed *) + debug_print "Grandparent: waiting for commands ..."; + let cmd = input_line cmd_pipe in + debug_print (sprintf "Grandparent: received %s command" cmd); + (match cmd with (* command from grandchild *) + | "test" -> + debug_print "Grandparent: Hello, world!"; + stop_http_daemon (); + output_string res_pipe "Grandparent: Hello, world!\n"; + flush res_pipe; + raise Restart_HTTP_daemon + | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *) + let bindings = + Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line) + in + stop_http_daemon (); + let log = new Uwobo_logger.processingLogger () in + List.iter + (fun binding -> (* add a binding *) + let pieces = Pcre.split ~pat:"," binding in + match pieces with + | [key; style] -> + log#log (sprintf "adding binding <%s,%s>" key style); + (try + styles#add key style; + with e -> + log#log (Printexc.to_string e)) + | _ -> log#log (sprintf "invalid binding %s" binding)) + bindings; + output_string res_pipe log#asHtml; + flush res_pipe; + raise Restart_HTTP_daemon + | line when Pcre.pmatch ~rex:remove_cmd_RE line -> (* /remove *) + stop_http_daemon (); + let arg = Pcre.replace ~rex:remove_cmd_RE line in + act_on_keys + arg styles res_pipe + styles#remove (fun () -> styles#removeAll) + "removing"; + raise Restart_HTTP_daemon + | line when Pcre.pmatch ~rex:reload_cmd_RE line -> (* /reload *) + stop_http_daemon (); + let arg = Pcre.replace ~rex:reload_cmd_RE line in + act_on_keys + arg styles res_pipe + styles#reload (fun () -> styles#reloadAll) + "reloading"; + raise Restart_HTTP_daemon + | cmd -> (* invalid interprocess command received *) + syslogger#log `Warning + (sprintf "Ignoring invalid interprocess command: '%s'" cmd)) + done + with Restart_HTTP_daemon -> + close_in cmd_pipe; (* these calls close also fds *) + close_out res_pipe;) + | 0 -> (* (5) child: serve http requests *) + Unix.close cmd_pipe_exit; + Unix.close res_pipe_entrance; + last_process := false; + let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in + let res_pipe = Unix.in_channel_of_descr res_pipe_exit in + debug_print "Starting HTTP daemon ..."; + (* next invocation doesn't return, process will keep on serving HTTP + requests until it will get killed by father *) + Http_daemon.start'~port ~mode:`Fork + (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ()) + | _ (* < 0 *) -> (* fork failed :-((( *) + failwith "Can't fork :-(" + done +in + + (* daemon initialization *) +try + Sys.catch_break true; + main () +with Sys.Break -> () (* 'die_nice' registered with at_exit *) + diff --git a/helm/uwobo/uwobo_common.ml b/helm/uwobo/uwobo_common.ml new file mode 100644 index 000000000..7664c93b2 --- /dev/null +++ b/helm/uwobo/uwobo_common.ml @@ -0,0 +1,111 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +open Printf;; + +exception Uwobo_failure of string;; + +let supported_properties = [ + "cdata-section-elements"; + "doctype-public"; + "doctype-system"; + "encoding"; + "indent"; + "media-type"; + "method"; + "omit-xml-declaration"; + "standalone"; + "version" +] + +let is_supported_property name = List.mem name supported_properties + +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,uri[&...]]
+ 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[&...]]][&prop.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 ", " supported_properties);; + +let pp_error = sprintf "

Error: %s

";; +let return_error msg outchan = + Http_daemon.respond ~body:(pp_error msg) outchan;; +let bad_request body outchan = + Http_daemon.respond_error ~code:400 ~body outchan +;; + + diff --git a/helm/uwobo/uwobo_common.mli b/helm/uwobo/uwobo_common.mli new file mode 100644 index 000000000..d1a1a8f8c --- /dev/null +++ b/helm/uwobo/uwobo_common.mli @@ -0,0 +1,41 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +exception Uwobo_failure of string + +val supported_properties: string list +val is_supported_property: string -> bool + +val usage_string: string + + (** return an ok (200) http response, which display in html an error message + *) +val return_error: string -> out_channel -> unit + (** return a 400 (bad request) http response *) +val bad_request: string -> out_channel -> unit + diff --git a/helm/uwobo/uwobo_engine.ml b/helm/uwobo/uwobo_engine.ml new file mode 100644 index 000000000..aad4f971b --- /dev/null +++ b/helm/uwobo/uwobo_engine.ml @@ -0,0 +1,140 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +open Printf;; +open Uwobo_common;; + + (** set this to true and uwobo will save transformation's intermediate results + in /tmp/uwobo_intermediate__.xml *) +let save_intermediate_results = false;; + +exception Unsupported_property of string;; + +let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform" +let outputS = Gdome.domString "output" +let q_outputS = Gdome.domString "xsl:output" + +let default_properties = [] (* no default properties *) + + (** apply an output property to an xslt stylesheet *) +let apply_property logger (element: Gdome.element) (name, value) = + if Uwobo_common.is_supported_property name then begin + logger#log `Debug (sprintf "Setting property: %s = %s" name value); + element#setAttribute (Gdome.domString name) (Gdome.domString value) + end else + raise (Unsupported_property name) + + (** 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. + Before applying "props" properties applies a set of default properties as + defined in "default_properties" *) +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#appendChild (elt :> Gdome.node)); + elt + | Some node -> new Gdome.element_of_node node) + in + List.iter + (apply_property logger (output_element :> Gdome.element)) + (default_properties @ 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 + = + (* "p_" prefix means "processed" *) + let (p_stylesheets, last_stylesheet) = styles#get keys in + logger#log `Debug "Creating input document ..."; + let intermediate_results_seqno = ref 0 in + 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 + logger#log `Debug + (sprintf "Gdome_xslt.applyStylesheet params=%s" + (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params))); + let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in + if save_intermediate_results then begin + let domImpl = Gdome.domImplementation () in + ignore + (domImpl#saveDocumentToFile + ~doc:res + ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml" + !intermediate_results_seqno (Unix.getpid())) + ()); + incr intermediate_results_seqno; + end; + res + with e -> raise (Uwobo_failure (Printexc.to_string e))) + input + p_stylesheets + in + let last_stylesheet = (* used to retrieve serialization options *) + 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/uwobo_engine.mli b/helm/uwobo/uwobo_engine.mli new file mode 100644 index 000000000..0631bdeed --- /dev/null +++ b/helm/uwobo/uwobo_engine.mli @@ -0,0 +1,50 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + + (** + @param logger logger for processing messages + @param styles stylesheets object + @param keys (ordered) list of stylesheet names to be applied + @param params function mapping stylesheet names to parameters list + @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 -> + styles: Uwobo_styles.styles -> + keys: string list -> + params: (string -> (string * string) list) -> + props: (string * string) list -> + input: Gdome.document -> + (out_channel -> unit) * string option * string option + diff --git a/helm/uwobo/uwobo_logger.ml b/helm/uwobo/uwobo_logger.ml new file mode 100644 index 000000000..bbd7e03f1 --- /dev/null +++ b/helm/uwobo/uwobo_logger.ml @@ -0,0 +1,88 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +open Printf;; + +type priority = [ + `Emerg | `Alert | `Crit | `Err | `Warning | `Notice | `Info | `Debug +] + +let int_of_priority = function + | `Emerg -> 0 + | `Alert -> 1 + | `Crit -> 2 + | `Err -> 3 + | `Warning -> 4 + | `Notice -> 5 + | `Info -> 6 + | `Debug -> 7 + +let string_of_priority = function + | `Emerg -> "EMERGENCY" + | `Alert -> "ALERT" + | `Crit -> "CRITICAL" + | `Err -> "ERROR" + | `Warning -> "WARNING" + | `Notice -> "NOTICE" + | `Info -> "INFO" + | `Debug -> "DEBUG" + +class sysLogger ?(level: priority = `Notice) ?(outchan = stderr) () = + object (self) + val level_no = int_of_priority level + val mutable enabled = false + method level = level + method levelNo = level_no + method enable = enabled <- true + method disable = enabled <- false + method log (prio: priority) msg = + let tm = Unix.localtime (Unix.time ()) in + if enabled && (int_of_priority prio <= level_no) then begin + fprintf outchan ("[UWOBO %02d/%02d/%4d %02d:%02d:%02d] %s: %s\n") + tm.Unix.tm_mday (tm.Unix.tm_mon + 1) (tm.Unix.tm_year + 1900) + tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + (string_of_priority prio) msg; + flush outchan + end + end + + (** non thread safe, a processingLogger is usually instantied locally for each + thread *) +class processingLogger = + let html_escape = Netencoding.Html.encode ~in_enc:`Enc_iso88591 () in + fun () -> + object + val mutable log_lines: string list = [] + method log msg = log_lines <- msg :: log_lines + method asText = String.concat "\n" (List.rev log_lines) + method asHtml = + sprintf + "\n%s\n" + (String.concat "
\n" (List.map html_escape (List.rev log_lines))) + end + diff --git a/helm/uwobo/uwobo_logger.mli b/helm/uwobo/uwobo_logger.mli new file mode 100644 index 000000000..b05cdda08 --- /dev/null +++ b/helm/uwobo/uwobo_logger.mli @@ -0,0 +1,67 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +type priority = [ + | `Emerg (* system is unusable *) + | `Alert (* action must be taken immediately *) + | `Crit (* critical conditions *) + | `Err (* error conditions *) + | `Warning (* warning conditions *) + | `Notice (* normal, but significant, condition *) + | `Info (* informational message *) + | `Debug (* debug-level message *) +] + + (** + Warning: logging is disabled by default, you have to invoke #enable method + before being able to log anything. + @param level minimum level of priority that will be reported, msg with + priority less than this will be ignored + @param outchan output channel on which output log messages *) +class sysLogger: + ?level: priority -> ?outchan: out_channel -> + unit -> + object + method level: priority + method levelNo: int + (** enable logging, by default logging is disabled *) + method enable: unit + (** disable logging *) + method disable: unit + (** log a message *) + method log: priority -> string -> unit + end + +class processingLogger: + unit -> + object + method log: string -> unit + method asText: string + method asHtml: string + end + diff --git a/helm/uwobo/uwobo_styles.ml b/helm/uwobo/uwobo_styles.ml new file mode 100644 index 000000000..9f954f63d --- /dev/null +++ b/helm/uwobo/uwobo_styles.ml @@ -0,0 +1,101 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +open Printf;; + +exception Stylesheet_not_found of string;; +exception Stylesheet_already_in of string;; + +class styles = + object (self) + (* INVARIANT: 'stylesheets' and 'uris' are in sync *) + + val mutable stylesheets = [] + val mutable uris = [] + val domImpl = Gdome.domImplementation () + + (** process an XSLT stylesheet *) + method private process uri = domImpl#createDocumentFromURI ~uri () + + method get 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) = + try + List.find (fun (k, _) -> k = key) stylesheets + with Not_found -> raise (Stylesheet_not_found key) + 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 = + if (List.mem_assoc key uris) then + raise (Stylesheet_already_in key) + else begin + uris <- (key, uri) :: uris; + stylesheets <- (key, self#process uri) :: stylesheets + end + + method remove key = + if not (List.mem_assoc key uris) then + raise (Stylesheet_not_found key) + else begin + uris <- List.remove_assoc key uris; + stylesheets <- List.remove_assoc key stylesheets + end + + method removeAll = uris <- []; stylesheets <- [] + + method list = + List.map + (fun (key, uri) -> + sprintf "key = %s, uri = %s" key (List.assoc key uris)) + uris + + method reload key = + (try + let uri = List.assoc key uris in + stylesheets <- + (key, self#process uri) :: (List.remove_assoc key stylesheets) + with Not_found -> + raise (Stylesheet_not_found key)) + + method reloadAll = + stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris + + end + diff --git a/helm/uwobo/uwobo_styles.mli b/helm/uwobo/uwobo_styles.mli new file mode 100644 index 000000000..5a0722f03 --- /dev/null +++ b/helm/uwobo/uwobo_styles.mli @@ -0,0 +1,44 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +exception Stylesheet_not_found of string;; +exception Stylesheet_already_in of string;; + +class styles: + object + 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 +