X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2Fuwobo%2Fsrc%2Focaml%2Fuwobo.ml;fp=helm%2Fuwobo%2Fsrc%2Focaml%2Fuwobo.ml;h=0000000000000000000000000000000000000000;hp=22714b29a837b6ba18bcb3edb144a5b3b2590568;hb=869549224eef6278a48c16ae27dd786376082b38;hpb=89262281b6e83bd2321150f81f1a0583645eb0c8 diff --git a/helm/uwobo/src/ocaml/uwobo.ml b/helm/uwobo/src/ocaml/uwobo.ml deleted file mode 100644 index 22714b29a..000000000 --- a/helm/uwobo/src/ocaml/uwobo.ml +++ /dev/null @@ -1,266 +0,0 @@ - -(* 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/. - *) - -(* TODO braindead situation: /add of a stylesheet which uri is an uwobo -invocation *) - -open Printf;; -open Uwobo_common;; - - (* 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 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 -in - - (* facilities *) -let pp_error = sprintf "

Error: %s

" in -let return_error msg outchan = - (* return an ok (200) http response, which display in html an error message *) - Http_daemon.respond ~body:(pp_error msg) outchan -in -let bad_request body outchan = (* return a bad request http response *) - 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 -syslogger#enable; -let styles = new Uwobo_styles.styles in -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,stylesheet[&...]]
- 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[&...]]][&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 ", " Uwobo_common.supported_properties) -in - - (* thread action *) -let callback req outchan = - (* 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 req styles outchan per_key_action all_keys_action logmsg = - let log = new Uwobo_logger.processingLogger () in - let keys = - try - Pcre.split ~pat:"," (req#param "keys") - with Http_request.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); - Http_daemon.respond ~body:log#asHtml outchan - in - let parse_apply_params = (* parse parameters for '/apply' action *) - 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 *) - in - try - 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 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; - Http_daemon.respond ~body:log#asHtml outchan - end) - | "/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) - | "/remove" -> - act_on_keys - req styles outchan - styles#remove (fun () -> styles#removeAll) "removing" - | "/reload" -> - act_on_keys - req styles outchan - styles#reload (fun () -> styles#reloadAll) "reloading" - | "/apply" -> - if Unix.fork () = 0 then - (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 *) - Uwobo_engine.apply - ~logger:syslogger ~styles ~keys ~input ~params ~props - in - let content_type = (* value of Content-Type HTTP response header *) - sprintf - "%s; charset=%s" - (match media_type with None -> default_media_type | Some t -> t) - (match encoding with None -> default_encoding | Some e -> e) - in - syslogger#log - `Debug - (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) - 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" daemon_name port); -syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ())); -Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *) -Http_daemon.start' ~port ~mode:`Thread callback; -syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name) -