From: Stefano Zacchiroli Date: Tue, 26 Nov 2002 13:27:22 +0000 (+0000) Subject: uwobo ocaml daily snapshot: Tue, 26 Nov 2002 14:26:36 +0100 X-Git-Tag: V_0_0_6~55 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=38d9fb165745652a56f92d48ab3b02153e5a187a;p=helm.git uwobo ocaml daily snapshot: Tue, 26 Nov 2002 14:26:36 +0100 --- diff --git a/helm/uwobo/src/ocaml/.cvsignore b/helm/uwobo/src/ocaml/.cvsignore new file mode 100644 index 000000000..3535ea5d5 --- /dev/null +++ b/helm/uwobo/src/ocaml/.cvsignore @@ -0,0 +1,6 @@ +*.cmi +*.cmo +*.cmx +*.cma +*.cmxa +uwobo* diff --git a/helm/uwobo/src/ocaml/.depend b/helm/uwobo/src/ocaml/.depend new file mode 100644 index 000000000..1fd2e0ef2 --- /dev/null +++ b/helm/uwobo/src/ocaml/.depend @@ -0,0 +1,9 @@ +uwobo.cmo: uwobo_engine.cmi uwobo_logger.cmi uwobo_styles.cmi +uwobo.cmx: uwobo_engine.cmx uwobo_logger.cmx uwobo_styles.cmx +uwobo_engine.cmo: uwobo_engine.cmi +uwobo_engine.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 new file mode 100644 index 000000000..6030b6eca --- /dev/null +++ b/helm/uwobo/src/ocaml/Makefile @@ -0,0 +1,38 @@ +REQUIRES = http gdome2 gdome2-xslt threads pcre +COMMONOPTS = -package "$(REQUIRES)" -pp camlp4o +OCAMLC = ocamlfind ocamlc $(COMMONOPTS) -thread +OCAMLOPT = ocamlfind ocamlopt $(COMMONOPTS) -thread +OCAMLDEP = ocamlfind ocamldep $(COMMONOPTS) +MODULES = uwobo_styles uwobo_logger uwobo_engine uwobo +OBJS = $(patsubst %,%.cmo,$(MODULES)) +OBJSOPT = $(patsubst %,%.cmx,$(MODULES)) + +all: opt +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) + $(OCAMLC) -linkpkg -o $@ $^ +uwobo.opt: $(OBJSOPT) + $(OCAMLOPT) -linkpkg -o $@ $^ + +clean: + rm -f *.cm[aiox] *.o uwobo{,.opt} + +.PHONY: all byte opt world depend clean + diff --git a/helm/uwobo/src/ocaml/uwobo.ml b/helm/uwobo/src/ocaml/uwobo.ml new file mode 100644 index 000000000..2ecf95518 --- /dev/null +++ b/helm/uwobo/src/ocaml/uwobo.ml @@ -0,0 +1,228 @@ + +(* Copyright (C) 2002, HELM Team. + * + * 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://cs.unibo.it/helm/. + *) + +open Printf;; + + (* debugging settings *) +let debug = true;; +let debug_level = `Debug;; +let debug_print s = if debug then prerr_endline s;; +let http_debug = false;; +Http_common.debug := http_debug;; + + (* environment settings *) +let daemon_name = "UWOBO OCaml";; +let default_port = 8082;; +let port_env_var = "UWOBO_PORT";; +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 +in + + (* facilities *) +let pp_error = sprintf "

Error: %s

" in +let invocation_error msg outchan = + (* return an ok (200) http response, which display in html an invocation error + message *) + Http_daemon.respond ~body:(pp_error msg) outchan +in +let bad_request body outchan = (* return a bad request http response *) + Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan +in + + (* values common to all threads *) +let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in +let styles = new Uwobo_styles.styles in +let styles_mutex = Mutex.create () in +let usage_string = "Help message: not yet written!!" in (* TODO *) + + (* thread action *) +let callback req outchan = + try + (match req#path with + | "/add" -> + (let bindings = req#param_all "bind" in + if bindings = [] then + invocation_error "No [key,stylesheet] binding provided" outchan + else begin + 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); + Mutex.lock styles_mutex; + (try + styles#add key style; + with e -> + log#log + (sprintf + "failure while adding <%s,%s>: exception %s" + key style (Printexc.to_string e))); + Mutex.unlock styles_mutex + | _ -> log#log (sprintf "invalid binding %s" binding)) + bindings; + Http_daemon.respond ~body:log#asHtml outchan + end) + | "/remove" -> (* TODO this branch is almost identical to "/reload" one *) + (let log = new Uwobo_logger.processingLogger () in + (match (Pcre.split ~pat:"," (req#param "keys")) with + | [] -> (* no key provided, unload all stylesheets *) + log#log "removing all stylesheets ..."; + Mutex.lock styles_mutex; + (try + styles#removeAll + with e -> + log#log + (sprintf + "failure while removing all stylesheets: exception %s" + (Printexc.to_string e))); + Mutex.unlock styles_mutex + | keys -> + List.iter + (fun key -> (* remove a single stylesheet *) + Mutex.lock styles_mutex; + log#log (sprintf "removing stylesheet %s" key); + (try + styles#remove key + with e -> + log#log + (sprintf + "failure while removing stylesheet %s: exception %s" + key (Printexc.to_string e))); + Mutex.unlock styles_mutex) + keys); + Http_daemon.respond ~body:log#asHtml outchan) + | "/list" -> + (let log = new Uwobo_logger.processingLogger () in + log#log "Stylesheet list:"; + styles#iterKeys (fun k -> log#log (styles#getInfo k)); + Http_daemon.respond ~body:log#asHtml outchan) + | "/reload" -> (* TODO this branch is almost identical to "/remove" one *) + (let log = new Uwobo_logger.processingLogger () in + (match (Pcre.split ~pat:"," (req#param "keys")) with + | [] -> (* no key provided, reload all stylesheets *) + log#log "reloading all stylesheets ..."; + Mutex.lock styles_mutex; + (try + styles#reloadAll + with e -> + log#log + (sprintf + "failure while reloading all stylesheets: exception %s" + (Printexc.to_string e))); + Mutex.unlock styles_mutex + | keys -> + List.iter + (fun key -> (* reload a single stylesheet *) + Mutex.lock styles_mutex; + log#log (sprintf "reloading stylesheet %s" key); + (try + styles#reload key + with e -> + log#log + (sprintf + "failure while reloading stylesheet %s: exception %s" + key (Printexc.to_string e))); + Mutex.unlock styles_mutex) + keys); + 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 local_params = ref [] in (* association list *) + let global_params = ref [] in (* association list *) + let properties = ref [] in (* association list *) + let get_style_param key name = + let params = (* try local params and fallback on global params *) + try List.assoc key !local_params with Not_found -> global_params + in + List.assoc name !params (* may raise Not_found *) + in + let get_property name = List.assoc name !properties in + let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}" x in + let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}" x in + let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+" x in + let add_global_param name value = + let name = Pcre.replace ~pat:"^param\\." name in + global_params := (name, value) :: !global_params + in + let add_local_param name value = + let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in + let (key, param) = (pieces.(1), pieces.(2)) in + (try + let previous_params = List.assoc key !local_params in + let new_params = (param, value) :: previous_params in + local_params := new_params :: (List.remove_assoc key !local_params) + with Not_found -> (* first local parameter for 'key' *) + local_params := [(param, value)] :: !local_params) + in + let add_property name value = + properties := + (Pcre.replace ~pat:"^prop\\." name, value) :: !properties + in + List.iter + (fun (name, value) -> + match name with + | name when is_global_param name -> add_global_param name value + | name when is_local_param name -> add_local_param name value + | name when is_property name -> add_property name value + | _ -> ()) + req#params; + Uwobo_engine.apply + ~logger ~styles ~keys ~input:xmluri + ~params:get_style_param ~props:get_property + outchan) + | "/help" -> Http_daemon.respond ~body:usage_string outchan + | invalid_request -> + Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan) + with + | Http_request.Param_not_found attr_name -> + bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan + | exc -> + Http_daemon.respond + ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc))) + outchan +in + + (* daemon initialization *) +syslogger#log + `Notice + (sprintf "%s started and listening on port %d\n" daemon_name port); +syslogger#log `Notice (sprintf "current directory is %s\n" (Sys.getcwd ())); +Http_daemon.start' ~port ~mode:`Thread callback; +syslogger#log `Notice (sprintf "%s is terminating, bye!\n" daemon_name) + diff --git a/helm/uwobo/src/ocaml/uwobo_logger.ml b/helm/uwobo/src/ocaml/uwobo_logger.ml new file mode 100644 index 000000000..c0e73b9b9 --- /dev/null +++ b/helm/uwobo/src/ocaml/uwobo_logger.ml @@ -0,0 +1,57 @@ + +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) () = + object + val level_no = int_of_priority level + val mutable enabled = false + method enable = enabled <- true + method disable = enabled <- false + method log (prio: priority) msg = + if enabled && (int_of_priority prio < level_no) then + prerr_endline (sprintf ("%s: %s") (string_of_priority prio) msg) + end + +class processingLogger = + let html_escape s = (* TODO too naive, use Nethtml.encode instead *) + Pcre.replace ~pat:"<" ~templ:"<" + (Pcre.replace ~pat:">" ~templ:">" + (Pcre.replace ~pat:"&" ~templ:"&" s)) + 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 new file mode 100644 index 000000000..6046c3877 --- /dev/null +++ b/helm/uwobo/src/ocaml/uwobo_logger.mli @@ -0,0 +1,34 @@ + +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 *) +] + + (** @param level minimum level of priority that will be reported, msg with + priority less than this will be ignored *) +class sysLogger: + ?level: priority -> + unit -> + object + (** 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 +