--- /dev/null
+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
--- /dev/null
+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
+
+++ /dev/null
-*.cmi
-*.cmo
-*.cmx
-*.cma
-*.cmxa
-uwobo
-uwobo.opt
+++ /dev/null
-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
+++ /dev/null
-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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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 <key, stylesheet> 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 *)
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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
-"
-<html>
- <head>
- <title>UWOBO's help message</title>
- </head>
- <body>
- <p>
- Usage: <kbd>http://hostname:uwoboport/</kbd><em>command</em>
- </p>
- <p>
- Available commands:
- </p>
- <p>
- <b><kbd>help</kbd></b><br />
- display this help message
- </p>
- <p>
- <b><kbd>add?bind=key,uri[&bind=key,uri[&...]]</kbd></b><br />
- load a new stylesheet, specified by <em>uri</em>, and bind it to key
- <em>key</em>
- </p>
- <p>
- <b><kbd>remove[?keys=key1,key2,...]</kbd></b><br />
- unload stylesheets specified by <em>key1, key2, ...</em> or all
- stylesheets if no key was given
- </p>
- <p>
- <b><kbd>reload[?keys=key1,key2,...]</kbd></b><br />
- reload stylesheets specified by <em>key1, key2, ...</em> or all
- stylesheets if no key was given
- </p>
- <p>
- <b><kbd>list</kbd></b><br />
- return a list of loaded stylesheets
- </p>
- <p>
- <b><kbd>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][&...]]]</kbd></b><br />
- apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
- input document, specified by <em>uri</em>.<br />
- Additional parameters can be set for each stylesheet application: global
- parameters (i.e. parameters passed to all stylesheets) are set using
- <em>param.name=value</em> syntax, per stylesheet parameters are set using
- <em>param.key.name=value</em> where <em>key</em> is the key of a loaded
- stylesheet.<br />
- Properties of the final chain output can be set too: valueless properties
- can be set using <em>prop.name</em> syntax, others can be set using
- <em>prop.name=value</em> syntax.<br />
- Current supported properties are: %s.
- </p>
- </body>
-</html>
-"
- (String.concat ", " supported_properties);;
-
-let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>";;
-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
-;;
-
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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_<seqno>_<pid>.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 *)
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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
- "<html><body>\n%s\n</body></html>"
- (String.concat "<br />\n" (List.map html_escape (List.rev log_lines)))
- end
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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
-
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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 <key, stylesheet> 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 *)
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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
+"
+<html>
+ <head>
+ <title>UWOBO's help message</title>
+ </head>
+ <body>
+ <p>
+ Usage: <kbd>http://hostname:uwoboport/</kbd><em>command</em>
+ </p>
+ <p>
+ Available commands:
+ </p>
+ <p>
+ <b><kbd>help</kbd></b><br />
+ display this help message
+ </p>
+ <p>
+ <b><kbd>add?bind=key,uri[&bind=key,uri[&...]]</kbd></b><br />
+ load a new stylesheet, specified by <em>uri</em>, and bind it to key
+ <em>key</em>
+ </p>
+ <p>
+ <b><kbd>remove[?keys=key1,key2,...]</kbd></b><br />
+ unload stylesheets specified by <em>key1, key2, ...</em> or all
+ stylesheets if no key was given
+ </p>
+ <p>
+ <b><kbd>reload[?keys=key1,key2,...]</kbd></b><br />
+ reload stylesheets specified by <em>key1, key2, ...</em> or all
+ stylesheets if no key was given
+ </p>
+ <p>
+ <b><kbd>list</kbd></b><br />
+ return a list of loaded stylesheets
+ </p>
+ <p>
+ <b><kbd>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][&...]]]</kbd></b><br />
+ apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
+ input document, specified by <em>uri</em>.<br />
+ Additional parameters can be set for each stylesheet application: global
+ parameters (i.e. parameters passed to all stylesheets) are set using
+ <em>param.name=value</em> syntax, per stylesheet parameters are set using
+ <em>param.key.name=value</em> where <em>key</em> is the key of a loaded
+ stylesheet.<br />
+ Properties of the final chain output can be set too: valueless properties
+ can be set using <em>prop.name</em> syntax, others can be set using
+ <em>prop.name=value</em> syntax.<br />
+ Current supported properties are: %s.
+ </p>
+ </body>
+</html>
+"
+ (String.concat ", " supported_properties);;
+
+let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>";;
+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
+;;
+
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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_<seqno>_<pid>.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 *)
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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
+ "<html><body>\n%s\n</body></html>"
+ (String.concat "<br />\n" (List.map html_escape (List.rev log_lines)))
+ end
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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
+
projects / helm.git / commitdiff