helm/uwobo/uwobo_common.ml

   1 (*
   2  * Copyright (C) 2003:
   3  *    Stefano Zacchiroli <zack@cs.unibo.it>
   4  *    for the HELM Team http://helm.cs.unibo.it/
   5  *
   6  *  This file is part of HELM, an Hypertextual, Electronic
   7  *  Library of Mathematics, developed at the Computer Science
   8  *  Department, University of Bologna, Italy.
   9  *
  10  *  HELM is free software; you can redistribute it and/or
  11  *  modify it under the terms of the GNU General Public License
  12  *  as published by the Free Software Foundation; either version 2
  13  *  of the License, or (at your option) any later version.
  14  *
  15  *  HELM is distributed in the hope that it will be useful,
  16  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18  *  GNU General Public License for more details.
  19  *
  20  *  You should have received a copy of the GNU General Public License
  21  *  along with HELM; if not, write to the Free Software
  22  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  23  *  MA  02111-1307, USA.
  24  *
  25  *  For details, see the HELM World-Wide-Web page,
  26  *  http://helm.cs.unibo.it/
  27  *)
  28
  29 open Printf ;;
  30
  31 exception Uwobo_failure of string ;;
  32
  33 let uwobo_namespace = "http://helm.cs.unibo.it/uwobo" ;;
  34 let xsl_namespace = "http://helm.cs.unibo.it/uwobo" ;;
  35
  36 let supported_properties = [
  37   "cdata-section-elements";
  38   "doctype-public";
  39   "doctype-system";
  40   "encoding";
  41   "indent";
  42   "media-type";
  43   "method";
  44   "omit-xml-declaration";
  45   "standalone";
  46   "version"
  47 ]
  48
  49 let is_supported_property name = List.mem name supported_properties
  50
  51 let version = "0.2.1" ;;
  52
  53 let usage_string =
  54   sprintf
  55 "
  56 <html>
  57   <head>
  58     <title>UWOBO's help message</title>
  59   </head>
  60   <body>
  61     <h1>UWOBO (version: %s)</h1>
  62     <h2>Information</h2>
  63     Version: %s
  64     <h2>Usage</h2>
  65     <p>
  66     Usage: <kbd>http://hostname:uwoboport/</kbd><em>command</em>
  67     </p>
  68     <p>
  69     Available commands:
  70     </p>
  71     <p>
  72       <b><kbd>help</kbd></b><br />
  73       display this help message
  74     </p>
  75     <p>
  76       <b><kbd>newsession?port=p</kbd></b><br />
  77       starts a new daemon on a given port <em>p</em>
  78     </p>
  79     <p>
  80       <b><kbd>kill</kbd></b><br />
  81       kills the daemon. The log file is mantained.
  82     </p>
  83     <p>
  84       <b><kbd>add?bind=key,uri[&bind=key,uri[&...]]</kbd></b><br />
  85       load a new stylesheet, specified by <em>uri</em>, and bind it to key
  86           <em>key</em>
  87     </p>
  88     <p>
  89       <b><kbd>remove?keys=[key1,key2,...]</kbd></b><br />
  90       unload stylesheets specified by <em>key1, key2, ...</em> or all
  91           stylesheets if no key was given
  92     </p>
  93     <p>
  94       <b><kbd>reload?keys=[key1,key2,...]</kbd></b><br />
  95       reload stylesheets specified by <em>key1, key2, ...</em> or all
  96           stylesheets if no key was given
  97     </p>
  98     <p>
  99       <b><kbd>list</kbd></b><br />
 100       return a list of loaded stylesheets
 101     </p>
 102     <p>
 103       <b><kbd>apply?xmluri=uri&keys=key1,key2,...[&errormode={ignore|comment|embed}][&debugmode={ignore|comment|embed}][&param.name=value[&param.name=value[&...]]][&param.key.name=value[&param.key.name=value[&...]]][&prop.name[=value][&prop.name[=value][&...]]]</kbd></b><br />
 104       apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
 105       input document, specified by <em>uri</em>.<br />
 106       Error and debugging modes could be ste to three different values.
 107       <em>ignore</em> means that LibXSLT messages are ignored; <em>comment</em>
 108       meanst that LibXSLT messages are embedded in the result document inside an
 109       XML like comment; <em>embed</em> means that LibXSLT messages are embedded
 110       at the beginning of the result document (as childs of the root node) in
 111       XML elements in the UWOBO namespace<br />
 112       Additional parameters can be set for each stylesheet application: global
 113       parameters (i.e. parameters passed to all stylesheets) are set using
 114       <em>param.name=value</em> syntax, per stylesheet parameters are set using
 115       <em>param.key.name=value</em> where <em>key</em> is the key of a loaded
 116       stylesheet.<br />
 117       Properties of the final chain output can be set too: valueless properties
 118       can be set using <em>prop.name</em> syntax, others can be set using
 119       <em>prop.name=value</em> syntax.<br />
 120       Current supported properties are: %s.
 121     </p>
 122   </body>
 123 </html>
 124 "
 125   version version
 126   (String.concat ", " supported_properties) (* supported properties *)
 127 ;;
 128
 129 let pp_error =
 130   sprintf
 131     "<html><body><span style=\"color:red\">Error: %s</span>%s</body></html>"
 132 ;;
 133 let return_error msg ?(body = "") outchan =
 134   Http_daemon.respond ~body:(pp_error msg body) outchan;;
 135 let bad_request body outchan =
 136   Http_daemon.respond_error ~code:400 ~body outchan
 137 ;;
 138
 139   (** {2 LibXSLT logging} *)
 140
 141 type xslt_msg =
 142   | LibXsltErrorMsg of string
 143   | LibXsltDebugMsg of string
 144 ;;
 145
 146 let string_of_xslt_msg = function
 147   | LibXsltErrorMsg msg -> "LibXSLT ERROR: " ^ msg
 148   | LibXsltDebugMsg msg -> "LibXSLT DEBUG: " ^ msg
 149 ;;
 150
 151 type xslt_msg_mode =
 152   | LibXsltMsgIgnore
 153   | LibXsltMsgComment
 154   | LibXsltMsgEmbed
 155 ;;
 156
 157 class libXsltLogger =
 158   let is_libxslt_error = function LibXsltErrorMsg _ -> true | _ -> false in
 159   let is_libxslt_debug = function LibXsltDebugMsg _ -> true | _ -> false in
 160   let flatten_libxslt_msg = function
 161     | LibXsltErrorMsg msg -> msg
 162     | LibXsltDebugMsg msg -> msg
 163   in
 164   object (self)
 165
 166     initializer
 167       Gdome_xslt.setErrorCallback
 168         (Some (fun msg -> self#appendMsg (LibXsltErrorMsg msg)));
 169       Gdome_xslt.setDebugCallback
 170         (Some (fun msg -> self#appendMsg (LibXsltDebugMsg msg)))
 171
 172     val mutable libXsltMsgs = []  (** libxslt's error and debugging messages *)
 173
 174       (* libxslt's error and debugging messages handling *)
 175
 176     method private appendMsg msg = libXsltMsgs <- msg :: libXsltMsgs
 177
 178     method clearMsgs = libXsltMsgs <- []
 179     method clearErrorMsgs =
 180       libXsltMsgs <- List.filter is_libxslt_debug libXsltMsgs
 181     method clearDebugMsgs =
 182       libXsltMsgs <- List.filter is_libxslt_error libXsltMsgs
 183
 184     method msgs = libXsltMsgs
 185     method errorMsgs =
 186       List.map flatten_libxslt_msg (List.filter is_libxslt_error libXsltMsgs)
 187     method debugMsgs =
 188       List.map flatten_libxslt_msg (List.filter is_libxslt_debug libXsltMsgs)
 189
 190   end
 191 ;;
 192