(* 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)