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.0" ;;
  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>add?bind=key,uri[&bind=key,uri[&...]]</kbd></b><br />
  77       load a new stylesheet, specified by <em>uri</em>, and bind it to key
  78           <em>key</em>
  79     </p>
  80     <p>
  81       <b><kbd>remove[?keys=key1,key2,...]</kbd></b><br />
  82       unload stylesheets specified by <em>key1, key2, ...</em> or all
  83           stylesheets if no key was given
  84     </p>
  85     <p>
  86       <b><kbd>reload[?keys=key1,key2,...]</kbd></b><br />
  87       reload stylesheets specified by <em>key1, key2, ...</em> or all
  88           stylesheets if no key was given
  89     </p>
  90     <p>
  91       <b><kbd>list</kbd></b><br />
  92       return a list of loaded stylesheets
  93     </p>
  94     <p>
  95       <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 />
  96       apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
  97       input document, specified by <em>uri</em>.<br />
  98       Error and debugging modes could be ste to three different values.
  99       <em>ignore</em> means that LibXSLT messages are ignored; <em>comment</em>
 100       meanst that LibXSLT messages are embedded in the result document inside an
 101       XML like comment; <em>embed</em> means that LibXSLT messages are embedded
 102       at the beginning of the result document (as childs of the root node) in
 103       XML elements in the UWOBO namespace<br />
 104       Additional parameters can be set for each stylesheet application: global
 105       parameters (i.e. parameters passed to all stylesheets) are set using
 106       <em>param.name=value</em> syntax, per stylesheet parameters are set using
 107       <em>param.key.name=value</em> where <em>key</em> is the key of a loaded
 108       stylesheet.<br />
 109       Properties of the final chain output can be set too: valueless properties
 110       can be set using <em>prop.name</em> syntax, others can be set using
 111       <em>prop.name=value</em> syntax.<br />
 112       Current supported properties are: %s.
 113     </p>
 114   </body>
 115 </html>
 116 "
 117   version version
 118   (String.concat ", " supported_properties) (* supported properties *)
 119 ;;
 120
 121 let pp_error =
 122   sprintf
 123     "<html><body><span style=\"color:red\">Error: %s</span>%s</body></html>"
 124 ;;
 125 let return_error msg ?(body = "") outchan =
 126   Http_daemon.respond ~body:(pp_error msg body) outchan;;
 127 let bad_request body outchan =
 128   Http_daemon.respond_error ~code:400 ~body outchan
 129 ;;
 130
 131   (** {2 LibXSLT logging} *)
 132
 133 type xslt_msg =
 134   | LibXsltErrorMsg of string
 135   | LibXsltDebugMsg of string
 136 ;;
 137
 138 let string_of_xslt_msg = function
 139   | LibXsltErrorMsg msg -> "LibXSLT ERROR: " ^ msg
 140   | LibXsltDebugMsg msg -> "LibXSLT DEBUG: " ^ msg
 141 ;;
 142
 143 type xslt_msg_mode =
 144   | LibXsltMsgIgnore
 145   | LibXsltMsgComment
 146   | LibXsltMsgEmbed
 147 ;;
 148
 149 class libXsltLogger =
 150   let is_libxslt_error = function LibXsltErrorMsg _ -> true | _ -> false in
 151   let is_libxslt_debug = function LibXsltDebugMsg _ -> true | _ -> false in
 152   let flatten_libxslt_msg = function
 153     | LibXsltErrorMsg msg -> msg
 154     | LibXsltDebugMsg msg -> msg
 155   in
 156   object (self)
 157
 158     initializer
 159       Gdome_xslt.setErrorCallback
 160         (Some (fun msg -> self#appendMsg (LibXsltErrorMsg msg)));
 161       Gdome_xslt.setDebugCallback
 162         (Some (fun msg -> self#appendMsg (LibXsltDebugMsg msg)))
 163
 164     val mutable libXsltMsgs = []  (** libxslt's error and debugging messages *)
 165
 166       (* libxslt's error and debugging messages handling *)
 167
 168     method private appendMsg msg = libXsltMsgs <- msg :: libXsltMsgs
 169
 170     method clearMsgs = libXsltMsgs <- []
 171     method clearErrorMsgs =
 172       libXsltMsgs <- List.filter is_libxslt_debug libXsltMsgs
 173     method clearDebugMsgs =
 174       libXsltMsgs <- List.filter is_libxslt_error libXsltMsgs
 175
 176     method msgs = libXsltMsgs
 177     method errorMsgs =
 178       List.map flatten_libxslt_msg (List.filter is_libxslt_error libXsltMsgs)
 179     method debugMsgs =
 180       List.map flatten_libxslt_msg (List.filter is_libxslt_debug libXsltMsgs)
 181
 182   end
 183 ;;
 184