(* 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 syslogger#enable; 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 syslogger#log `Debug (sprintf "Received request: %s" req#path); (match req#path with | "/add" -> (let bindings = req#paramAll "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 let keys = try Pcre.split ~pat:"," (req#param "keys") with Http_request.Param_not_found _ -> [] in (match 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 let keys = try Pcre.split ~pat:"," (req#param "keys") with Http_request.Param_not_found _ -> [] in (match 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 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 (params, props) = 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 *) req#params in Uwobo_engine.apply ~logger ~styles ~keys ~input:xmluri ~params ~props 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)