(* 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 quando si prova ad applicare uno stylesheet che non e' stato caricato
viene lasciata passare una eccezione Not_found *)
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 = "Help message: not yet written!!" in (* TODO *)
(* 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 ()));
Http_daemon.start' ~port ~mode:`Thread callback;
syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)