scripts/lib/wikilib.ml

   1 (* COCANWIKI - a wiki written in Objective CAML.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: wikilib.ml,v 1.1 2004/10/21 11:42:05 rich Exp $
   5  *
   6  * This program is free software; you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation; either version 2 of the License, or
   9  * (at your option) any later version.
  10  *
  11  * This program is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  * GNU General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU General Public License
  17  * along with this program; see the file COPYING.  If not, write to
  18  * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19  * Boston, MA 02111-1307, USA.
  20  *)
  21
  22 open Apache
  23 open Registry
  24 open Cgi
  25 open Cgi_escape
  26 open Printf
  27
  28 open ExtString
  29
  30 open Cocanwiki_strings
  31
  32 (* Generate a URL for a new page with the given title.  This code checks
  33  * if the URL already exists in the database and can return one of several
  34  * errors.
  35  *)
  36 type genurl_error_t = GenURL_OK of string
  37                     | GenURL_TooShort
  38                     | GenURL_BadURL
  39                     | GenURL_Duplicate of string
  40
  41 let nontrivial_re = Pcre.regexp ~flags:[`CASELESS] "[a-z0-9]"
  42
  43 let generate_url_of_title (dbh : Dbi.connection) hostid title =
  44   (* Create a suitable URL from this title. *)
  45   let url =
  46     String.map (function
  47                   | '\000' .. ' ' | '<' | '>' | '&' | '"'
  48                   | '+' | '#' | '%' | '?'
  49                       -> '_'
  50                   | c -> Char.lowercase c) title in
  51
  52   (* Check URL is not too trivial. *)
  53   if not (Pcre.pmatch ~rex:nontrivial_re url) then
  54     GenURL_TooShort
  55   (* URL cannot begin with '_'. *)
  56   else if url.[0] = '_' then
  57     GenURL_BadURL
  58   else (
  59     (* Check that the URL doesn't already exist in the database.  If it does
  60      * then it probably means that another page exists with similar enough
  61      * content, so we should redirect to there instead.
  62      *)
  63     let sth = dbh#prepare_cached "select 1 from pages
  64                                    where hostid = ? and url = ?" in
  65     sth#execute [`Int hostid; `String url];
  66
  67     try
  68       sth#fetch1int ();
  69       GenURL_Duplicate url
  70     with
  71         Not_found ->
  72           GenURL_OK url
  73   )
  74
  75 (* Obscure a mailto: URL against spammers. *)
  76 let obscure_mailto url =
  77   if String.length url > 8 then (
  78     let c7 = Char.code url.[7] in
  79     let c8 = Char.code url.[8] in
  80     let start = String.sub url 0 7 in
  81     let rest = escape_html_tag (String.sub url 9 (String.length url - 9)) in
  82     sprintf "%s&#x%02x;&#x%02x;%s" start c7 c8 rest
  83   )
  84   else
  85     url
  86
  87 (* Convert Wiki markup to XHTML 1.0.
  88  *
  89  * Shortcomings:
  90  * Doesn't support multi-level bullet points. (XXX)
  91  * Intra-page links. (XXX)
  92  *)
  93
  94 (* This matches any markup. *)
  95 let markup_re =
  96   let link = "\\[\\[\\s*(?:.+?)\\s*(?:\\|.+?\\s*)?\\]\\]" in
  97   let tag = "</?(?:b|i|strong|em|code|tt|sup|sub|nowiki|big|small|strike|s|br)>" in
  98   Pcre.regexp ("(.*?)((?:" ^ link ^ ")|(?:" ^ tag ^ "))(.*)")
  99
 100 (* This matches links only, and should be compatible with the link contained
 101  * in the above regexp.
 102  *)
 103 let link_re = Pcre.regexp "\\[\\[\\s*(.+?)\\s*(?:\\|(.+?)\\s*)?\\]\\]"
 104
 105 let image_re =
 106   Pcre.regexp "^(image|thumb(?:nail)?):\\s*([a-z0-9][_a-z0-9]*\\.(?:jpg|jpeg|gif|ico|png))$"
 107 let file_re =
 108   Pcre.regexp "^file:\\s*([a-z0-9][-._a-z0-9]*)$"
 109
 110 let url_re = Pcre.regexp "^[a-z]+://"
 111 let mailto_re = Pcre.regexp "^mailto:"
 112
 113 (* Links. *)
 114 let markup_link dbh hostid link =
 115   let subs = Pcre.exec ~rex:link_re link in
 116   let url = Pcre.get_substring subs 1 in
 117
 118   let tag name = function
 119       `Null -> ""
 120     | `String v -> " " ^ name ^ "=\"" ^ escape_html_tag v ^ "\""
 121   in
 122
 123   if Pcre.pmatch ~rex:image_re url then (
 124     (* It may be an image. *)
 125     let subs = Pcre.exec ~rex:image_re url in
 126     let is_thumb = (Pcre.get_substring subs 1).[0] = 't' in
 127     let name = Pcre.get_substring subs 2 in
 128
 129     let sql = "select id, " ^
 130               (if is_thumb then "tn_width, tn_height"
 131                else "width, height") ^
 132               ", alt, title, longdesc, class
 133                from images
 134               where hostid = ? and name = ?" in
 135     let sth = dbh#prepare_cached sql in
 136     sth#execute [`Int hostid; `String name];
 137
 138     try
 139       let imageid, width, height, alt, title, longdesc, clasz =
 140         match sth#fetch1 () with
 141             [`Int imageid; `Int width; `Int height; `String alt;
 142              (`Null | `String _) as title;
 143              (`Null | `String _) as longdesc;
 144              (`Null | `String _) as clasz] ->
 145               imageid, width, height, alt, title, longdesc, clasz
 146           | _ -> assert false in
 147
 148       let link = "/_image/" ^ escape_url name in
 149
 150       (if is_thumb then "<a href=\"" ^ link ^ "\">" else "") ^
 151       "<img src=\"" ^ link ^ "?version=" ^ string_of_int imageid ^
 152       (if is_thumb then "&thumbnail=1" else "") ^
 153       "\" width=\"" ^
 154       string_of_int width ^
 155       "\" height=\"" ^
 156       string_of_int height ^
 157       "\" alt=\"" ^
 158       escape_html_tag alt ^
 159       "\"" ^
 160       tag "title" title ^
 161       tag "longdesc" longdesc ^
 162       tag "class" clasz ^
 163       "/>" ^
 164       (if is_thumb then "</a>" else "")
 165     with
 166         Not_found ->
 167           (* Image not found. *)
 168           "<a class=\"image_not_found\" " ^
 169           "href=\"/_bin/upload_image_form.cmo?name=" ^
 170           escape_url name ^
 171           "\">" ^
 172           escape_html name ^
 173           "</a>"
 174   ) else if Pcre.pmatch ~rex:file_re url then (
 175     (* It may be a file. *)
 176     let subs = Pcre.exec ~rex:file_re url in
 177     let name = Pcre.get_substring subs 1 in
 178
 179     let sth = dbh#prepare_cached "select title
 180                                     from files
 181                                    where hostid = ? and name = ?" in
 182     sth#execute [`Int hostid; `String name];
 183
 184     try
 185       let title =
 186         match sth#fetch1 () with
 187             [(`Null | `String _) as title] -> title
 188           | _ -> assert false in
 189
 190       "<a href=\"/_file/" ^
 191       escape_url name ^
 192       "\"" ^
 193       tag "title" title ^
 194       ">" ^
 195       escape_html name ^
 196       "</a>"
 197     with
 198         Not_found ->
 199           (* File not found. *)
 200           "<a class=\"file_not_found\" " ^
 201           "href=\"/_bin/upload_file_form.cmo?name=" ^
 202           escape_url name ^
 203           "\">" ^
 204           escape_html name ^
 205           "</a>"
 206   ) else (
 207     (* Pcre changed behaviour between versions.  Previously a non-capture
 208      * would return "".  Now it throws 'Not_found'.
 209      *)
 210     let text =
 211       try Pcre.get_substring subs 2
 212       with Not_found -> "" in
 213     let text = if text = "" then url else text in
 214
 215     (* XXX Escaping here is very hairy indeed.  (See also the obscure_mailto
 216      * function which performs some escaping ...)
 217      *)
 218
 219     let url, clasz, title =
 220       if Pcre.pmatch ~rex:url_re url then
 221         escape_html_tag url, "external", url (* http://.... *)
 222       else if Pcre.pmatch ~rex:mailto_re url then
 223         obscure_mailto url, "mailto", url
 224       else if String.length url >= 1 && url.[0] = '/' then (* /index etc. *)
 225         escape_html_tag url, "internal", url
 226       else (
 227         let title = url in
 228         (* Look up the 'URL' against the titles in the database and
 229          * obtain the real URL.
 230          *)
 231         let sth = dbh#prepare_cached "select url from pages
 232                                        where hostid = ? and url is not null
 233                                          and lower (title) = lower (?)" in
 234         sth#execute [`Int hostid; `String url];
 235
 236         try
 237           let url = sth#fetch1string () in
 238           "/" ^ url, "internal", title
 239         with
 240             Not_found ->
 241               (* It might be a template page ...  These pages don't
 242                * exist in the template, but can be synthesized on the
 243                * fly by page.ml.
 244                *)
 245               let is_template_page url =
 246                 let sth = dbh#prepare_cached "select 1 from templates
 247                                                where ? ~ url_regexp
 248                                                order by ordering
 249                                                limit 1" in
 250                 sth#execute [`String url];
 251
 252                 try sth#fetch1int () = 1 with Not_found -> false
 253               in
 254
 255               if is_template_page url then
 256                 "/" ^ url, "internal", title
 257               else
 258                 (* No, it really doesn't exist, so make it a link to
 259                  * a new page.
 260                  *)
 261               "/_bin/edit.cmo?title=" ^ escape_url url, "newpage", title
 262       ) in
 263
 264     "<a href=\"" ^ url ^
 265     "\" class=\"" ^ clasz ^
 266     "\" title=\"" ^ escape_html_tag title ^ "\">" ^
 267     escape_html text ^ "</a>"
 268   )
 269
 270 type find_t = FoundNothing
 271             | FoundOpen of string * string * string
 272             | FoundClose of string * string * string * string
 273             | FoundLink of string * string * string
 274
 275 let _markup_paragraph dbh hostid text =
 276   let find_earliest_markup text =
 277     let convert_b_and_i elem =
 278       if elem = "b" then "strong"
 279       else if elem = "i" then "em"
 280       else elem
 281     in
 282
 283     try
 284       let subs = Pcre.exec ~rex:markup_re text in
 285       let first = Pcre.get_substring subs 1 in
 286       let markup = Pcre.get_substring subs 2 in
 287       let rest = Pcre.get_substring subs 3 in
 288       if String.length markup > 2 &&
 289         markup.[0] = '[' && markup.[1] = '[' then (
 290           let link = markup_link dbh hostid markup in
 291           FoundLink (first, link, rest)
 292         )
 293       else if String.length markup > 2 &&
 294         markup.[0] = '<' && markup.[1] = '/' then (
 295           let elem = String.sub markup 2 (String.length markup - 3) in
 296           let elem = convert_b_and_i elem in
 297           FoundClose (first, elem, rest, markup ^ rest)
 298         )
 299       else if String.length markup > 1 && markup.[0] = '<' then (
 300         let elem = String.sub markup 1 (String.length markup - 2) in
 301         let elem = convert_b_and_i elem in
 302         FoundOpen (first, elem, rest)
 303       )
 304       else
 305         failwith ("bad regexp: markup is '" ^ markup ^ "'");
 306     with
 307         Not_found -> FoundNothing
 308   in
 309
 310   (* This code performs markup for a "paragraph" unit.  The strategy
 311    * is to look for the next matching markup or link, process that, and
 312    * then continue recursively with the remainder of the string.  We also
 313    * maintain a stack which is our current level of nesting of <b>-like
 314    * operators.
 315    *)
 316   let rec loop = function
 317     | "", [] -> [""]                    (* base case *)
 318
 319     | text, ("nowiki" :: stack) ->
 320         (*prerr_endline ("nowiki case: text = " ^ text);*)
 321
 322         (* If the top of the stack is <nowiki> then we're just looking for
 323          * the closing </nowiki>, and nothing else matters. *)
 324         (match Pcre.split ~pat:"</nowiki>" ~max:2 text with
 325            | [] -> loop ("", stack)
 326            | [x] -> escape_html x :: loop ("", stack)
 327            | [x;y] -> escape_html x :: loop (y, stack)
 328            | _ -> assert false)
 329
 330     | "", (x :: xs) ->                  (* base case, popping the stack *)
 331         "</" :: x :: ">" :: loop ("", xs)
 332
 333     | text, [] ->
 334         (*prerr_endline ("text = " ^ text ^ ", stack empty");*)
 335
 336         (* Look for the earliest possible matching markup.  Because the
 337          * stack is empty, we're not looking for closing tags.
 338          *)
 339         (match find_earliest_markup text with
 340            | FoundNothing -> escape_html text :: []
 341            | FoundClose (first, elem, rest, _) ->
 342                (* close tags ignored *)
 343                escape_html first :: "&lt;/" :: escape_html elem :: "&gt;" ::
 344                  loop (rest, [])
 345            | FoundOpen (first, elem, rest) when elem = "nowiki" ->
 346                (* handle <nowiki> specially ... *)
 347                escape_html first :: loop (rest, elem :: [])
 348            | FoundOpen (first, elem, rest) when elem = "br" ->
 349                (* handle <br> specially ... *)
 350                escape_html first :: "<br/>" :: loop (rest, [])
 351            | FoundOpen (first, elem, rest) ->
 352                (* open tag - push it onto the stack *)
 353                escape_html first :: "<" :: elem :: ">" :: loop (rest, [elem])
 354            | FoundLink (first, link, rest) ->
 355                escape_html first :: link :: loop (rest, [])
 356         )
 357
 358     | text, ((x :: xs) as stack) ->
 359         (*prerr_endline ("text = " ^ text ^ ", top of stack = " ^ x ^
 360           ", stack size = " ^ string_of_int (List.length stack));*)
 361
 362         (* Look for the earliest possible matching markup. *)
 363         (match find_earliest_markup text with
 364            | FoundNothing -> escape_html text :: loop ("", stack)
 365            | FoundClose (first, elem, rest, _) when x = elem ->
 366                (* matching close tag *)
 367                escape_html first :: "</" :: elem :: ">" :: loop (rest, xs)
 368            | FoundClose (first, elem, rest, elem_rest) ->
 369                (* non-matching close tag *)
 370                escape_html first :: "</" :: x :: ">" :: loop (elem_rest, xs)
 371            | FoundOpen (first, elem, rest) when elem = "nowiki" ->
 372                (* handle <nowiki> specially ... *)
 373                escape_html first :: loop (rest, elem :: stack)
 374            | FoundOpen (first, elem, rest) when elem = "br" ->
 375                (* handle <br> specially ... *)
 376                escape_html first :: "<br/>" :: loop (rest, stack)
 377            | FoundOpen (first, elem, rest) ->
 378                (* open tag - push it onto the stack *)
 379                escape_html first :: "<" :: elem :: ">" ::
 380                  loop (rest, elem :: stack)
 381            | FoundLink (first, link, rest) ->
 382                (* link *)
 383                escape_html first :: link :: loop (rest, stack)
 384         )
 385   in
 386
 387   (*prerr_endline ("original markup = " ^ text);*)
 388   let text = loop (text, []) in
 389   let text = String.concat "" text in
 390   (*prerr_endline ("after loop = " ^ text);*)
 391   text
 392
 393 let markup_paragraph ~first_para dbh hostid text =
 394   let p = if first_para then "<p class=\"first_para\">" else "<p>" in
 395   p ^ _markup_paragraph dbh hostid text ^ "</p>"
 396
 397 let markup_heading dbh hostid level text =
 398   let text = _markup_paragraph dbh hostid text in
 399   sprintf "<h%d>%s</h%d>" level text level
 400
 401 let markup_ul dbh hostid lines =
 402   "<ul><li>" ^
 403   String.concat "</li>\n<li>"
 404     (List.map (fun t -> _markup_paragraph dbh hostid t) lines) ^
 405   "</li></ul>"
 406
 407 let markup_ol dbh hostid lines =
 408   "<ol><li>" ^
 409   String.concat "</li>\n<li>"
 410     (List.map (fun t -> _markup_paragraph dbh hostid t) lines) ^
 411   "</li></ol>"
 412
 413 let markup_pre lines =
 414   "<pre>\n" ^
 415   String.concat "\n" (List.map Cgi_escape.escape_html lines) ^
 416   "\n</pre>\n"
 417
 418 (* Validate HTML permitted in between <html> ... </html> markers.
 419  * Note that what we support is a very limited but strict subset of XHTML
 420  * 1.0.  Actually, that's not true.  We should really use an XML parser
 421  * and a proper DTD here to ensure elements only appear in the correct
 422  * context ...
 423  *)
 424 let split_tags_re = Pcre.regexp ~flags:[`DOTALL] "<.*?>|[^<]+"
 425
 426 let open_attr_re = Pcre.regexp "^<([a-z]+)\\s*([^>]*?)(/?)>$"
 427 let close_attr_re = Pcre.regexp "^</([a-z]+)>$"
 428
 429 let allowed_elements =
 430   let basic = [
 431     "p", [];
 432     "ul", []; "ol", []; "li", [];
 433     "pre", []; "blockquote", ["cite"];
 434     "strong", []; "em", []; "dfn", []; "code", []; "tt", [];
 435     "samp", []; "kbd", []; "var", []; "cite", [];
 436     "sup", []; "sub", []; "q", [];
 437     "abbr", []; "acronym", [];
 438     "b", []; "i", [];
 439     "big", []; "small", []; "strike", []; "s", [];
 440     "div", []; "span", [];
 441     "br", [];
 442   ] in
 443   let headers = [ "h3", []; "h4", []; "h5", []; "h6", [] ] in
 444   let links = [ "a", ["href"; "name"] ] in
 445   let images = [ "img", ["src"; "alt"; "width"; "height"; "longdesc"] ] in
 446
 447   let forms = [
 448     "form", [ "method"; "action"; "enctype" ];
 449     "input", [ "name"; "value"; "type"; "size"; "maxlength"; "src"; "alt" ];
 450     "textarea", [ "name"; "rows"; "cols" ];
 451   ] in
 452
 453   let tables = [
 454     "table", []; "tr", [];
 455     "th", [ "colspan"; "rowspan" ]; "td", [ "colspan"; "rowspan" ];
 456     "thead", []; "tbody", []
 457   ] in
 458
 459   basic @ headers @ links @ images @ forms @ tables
 460
 461 let standard_tags = [ "title"; "lang"; "class"; "id" ]
 462
 463 (* Parse a list of tags like:
 464  * name="value" name="value with space"
 465  * into an assoc list.  The tricky bit is that there may be
 466  * spaces within the quoted strings.
 467  *)
 468 let parse_tags str =
 469   if str = "" then []                   (* Very common case. *)
 470   else (
 471     let len = String.length str in
 472
 473     let fail () = invalid_arg ("bad tags near: " ^ truncate 20 str) in
 474     let get_alphas i =
 475       let b = Buffer.create 100 in
 476       let rec loop i =
 477         if i < len && isalpha str.[i] then (
 478           Buffer.add_char b str.[i];
 479           loop (i+1)
 480         ) else
 481           Buffer.contents b, i
 482       in
 483       loop i
 484     in
 485     let get_to_next_quote i =
 486       let b = Buffer.create 100 in
 487       let rec loop i =
 488         if i < len && str.[i] <> '"' then (
 489           Buffer.add_char b str.[i];
 490           loop (i+1)
 491         ) else
 492           Buffer.contents b, (i+1)
 493       in
 494       loop i
 495     in
 496
 497     let r = ref [] in
 498     let rec loop i =
 499       if i >= len then !r
 500       else (
 501         let c = str.[i] in
 502         if isspace c then loop (i+1)
 503         else if isalpha c then (
 504           let name, i = get_alphas i in
 505           if String.length str > i && str.[i] = '=' && str.[i+1] = '"' then (
 506             let value, i = get_to_next_quote (i+2) in
 507             r := (name, value) :: !r;
 508             loop i
 509           )
 510           else fail ()
 511         )
 512         else fail ()
 513       )
 514     in
 515     loop 0
 516   )
 517
 518 type valid_t = VText of string
 519              | VOpen of string * (string * string) list
 520              | VClose of string
 521
 522 let validate html =
 523   (* Split into attrs and non-attrs.  We end up with a list like this:
 524    * [ "<ul>"; "<li>"; "Some text"; "</li>"; ... ]
 525    *)
 526   let html =
 527     try
 528       let html = Pcre.extract_all ~rex:split_tags_re html in
 529       let html = Array.to_list html in
 530       List.map (function [| a |] -> a | _ -> assert false) html
 531     with
 532         Not_found -> [] in
 533
 534   (* Parse up each attribute to get the tags. *)
 535   let html =
 536     List.concat
 537       (List.map
 538          (fun str ->
 539             if String.length str >= 2 && str.[0] = '<' then (
 540               try
 541                 if str.[1] <> '/' then (
 542                   (* Possible open attr. *)
 543                   let subs = Pcre.exec ~rex:open_attr_re str in
 544                   let attr = Pcre.get_substring subs 1 in
 545                   let tags = Pcre.get_substring subs 2 in
 546                   let close = Pcre.get_substring subs 3 = "/" in
 547                   let tags = parse_tags tags in
 548                   if not close then
 549                     [VOpen (attr, tags)]
 550                   else
 551                     [VOpen (attr, tags); VClose attr]
 552                 ) else (
 553                   (* Possible close attr. *)
 554                   let subs = Pcre.exec ~rex:close_attr_re str in
 555                   let attr = Pcre.get_substring subs 1 in
 556                   [VClose attr]
 557                 )
 558               with
 559                   Not_found ->
 560                     invalid_arg ("invalid element near " ^ truncate 20 str)
 561             ) else (
 562               (* Ordinary text.  Check no < or > characters. *)
 563               (* XXX Check for valid &quoted; entities. *)
 564               if String.contains str '<' || String.contains str '>' then
 565                 invalid_arg
 566                   ("unquoted '<' or '>' characters near " ^ truncate 20 str);
 567               [VText str]
 568             )
 569          ) html
 570       ) in
 571
 572   (* Check that opening/closing tags match. *)
 573   let rec loop stack html =
 574     match stack, html with
 575       | [], [] -> ()
 576       | (attr :: _), [] ->
 577           invalid_arg ("mismatched element: " ^ truncate 20 attr)
 578       | stack, (VOpen (attr, _) :: xs) ->
 579           loop (attr :: stack) xs
 580       | (attr1 :: stack), (VClose attr2 :: xs) when attr1 = attr2 ->
 581           loop stack xs
 582       | (attr1 :: stack), (VClose attr2 :: xs) ->
 583           invalid_arg ("open/close elements don't match: " ^
 584                        truncate 20 attr1 ^ " and: " ^
 585                        truncate 20 attr2)
 586       | [], (VClose attr2 :: _) ->
 587           invalid_arg ("close element with no matching open: " ^
 588                        truncate 20 attr2)
 589       | stack, (VText _ :: xs) ->
 590           loop stack xs
 591   in
 592   loop [] html;
 593
 594   (* Now check that we only use the permitted elements. *)
 595   let rec loop = function
 596     | [] -> ()
 597     | (VOpen (attr, tags)) :: xs ->
 598         (try
 599            let allowed_tags = List.assoc attr allowed_elements in
 600            let allowed_tags = allowed_tags @ standard_tags in
 601            List.iter (fun (tag, _) ->
 602                         if not (List.mem tag allowed_tags) then
 603                           raise Not_found) tags;
 604            loop xs
 605          with
 606              Not_found ->
 607                invalid_arg ("this HTML attr is not allowed or contains a " ^
 608                             "tag which is not permitted: " ^
 609                             truncate 20 attr))
 610     | _ :: xs -> loop xs
 611   in
 612   loop html
 613
 614 type preline_t = STpHTML of string list (* Block of HTML. *)
 615                | STpLine of string      (* A line. *)
 616
 617 type line_t = STBlank
 618             | STHeading of int * string (* <h3>, <h4>, ... *)
 619             | STUnnumbered of string list (* <ul> *)
 620             | STNumbered of string list (* <ol> *)
 621             | STPreformatted of string list (* <pre> *)
 622             | STParagraph of string     (* Ordinary <p> *)
 623             | STHTML of string list     (* Block of (unvalidated) HTML. *)
 624
 625 let split_lines_re = Pcre.regexp "\\r?\\n"
 626 let blank_re = Pcre.regexp "^\\s*$"
 627 let heading_re = Pcre.regexp "^(=+)\\s+(.*)"
 628 let unnumbered_re = Pcre.regexp "^(\\*)\\s+(.*)"
 629 let numbered_re = Pcre.regexp "^(\\#)\\s+(.*)"
 630 let preformatted_re = Pcre.regexp "^ (.*)"
 631 let html_open_re = Pcre.regexp "^<html>\\s*$"
 632 let html_close_re = Pcre.regexp "^</html>\\s*$"
 633
 634 let xhtml_of_content (dbh : Dbi.connection) hostid text =
 635   (* Split the text into lines. *)
 636   let lines = Pcre.split ~rex:split_lines_re text in
 637
 638   (* HTML blocks span multiple lines, so isolate these out first. *)
 639   let rec loop = function
 640     | [] -> []
 641     | line :: xs when Pcre.pmatch ~rex:html_open_re line ->
 642       (* Find the closing tag.  If not found, ignore opening tag. *)
 643       let rec loop' acc = function
 644         | [] -> None
 645         | line :: xs when Pcre.pmatch ~rex:html_close_re line ->
 646           Some (List.rev acc, xs)
 647         | line :: xs ->
 648             let acc = line :: acc in
 649             loop' acc xs
 650       in
 651       (match loop' [] xs with
 652          | Some (html, rest) ->
 653              STpHTML html :: loop rest
 654          | None ->
 655              STpLine line :: loop xs)
 656     | line :: xs ->
 657         STpLine line :: loop xs
 658   in
 659   let lines = loop lines in
 660
 661   (* Iterate over the lines to isolate headers and paragraphs. *)
 662   let lines =
 663     List.map
 664       (function
 665          | STpLine line ->
 666              if Pcre.pmatch ~rex:preformatted_re line then (
 667                let subs = Pcre.exec ~rex:preformatted_re line in
 668                let line = Pcre.get_substring subs 1 in
 669                STPreformatted [line]
 670              )
 671              else if Pcre.pmatch ~rex:blank_re line then
 672                STBlank
 673              else if Pcre.pmatch ~rex:heading_re line then (
 674                let subs = Pcre.exec ~rex:heading_re line in
 675                let count = String.length (Pcre.get_substring subs 1) + 2 in
 676                let line = Pcre.get_substring subs 2 in
 677                STHeading (count, line)
 678              )
 679              else if Pcre.pmatch ~rex:unnumbered_re line then (
 680                let subs = Pcre.exec ~rex:unnumbered_re line in
 681                let line = Pcre.get_substring subs 2 in
 682                STUnnumbered [line]
 683              )
 684              else if Pcre.pmatch ~rex:numbered_re line then (
 685                let subs = Pcre.exec ~rex:numbered_re line in
 686                let line = Pcre.get_substring subs 2 in
 687                STNumbered [line]
 688              ) else
 689                STParagraph line
 690          | STpHTML html ->
 691              STHTML html
 692       ) lines in
 693
 694   (* Aggregate paragraphs and lists. *)
 695   let rec loop = function
 696     | [] -> []
 697     | STHeading (_, _) as h :: xs ->
 698         h :: loop xs
 699     | STUnnumbered lines1 :: STUnnumbered lines2 :: xs ->
 700         loop (STUnnumbered (lines1 @ lines2) :: xs)
 701     | STUnnumbered lines :: xs ->
 702         STUnnumbered lines :: loop xs
 703     | STNumbered lines1 :: STNumbered lines2 :: xs ->
 704         loop (STNumbered (lines1 @ lines2) :: xs)
 705     | STNumbered lines :: xs ->
 706         STNumbered lines :: loop xs
 707     | STPreformatted lines1 :: STPreformatted lines2 :: xs ->
 708         loop (STPreformatted (lines1 @ lines2) :: xs)
 709     | STPreformatted lines :: xs ->
 710         STPreformatted lines :: loop xs
 711     | STParagraph line1 :: STParagraph line2 :: xs ->
 712         loop (STParagraph (line1 ^ " " ^ line2) :: xs)
 713     | STParagraph line :: xs ->
 714         STParagraph line :: loop xs
 715     | STHTML html as h :: xs ->
 716         h :: loop xs
 717     | STBlank :: xs ->
 718         loop xs
 719   in
 720   let lines = loop lines in
 721
 722   (* In the following map, first_para records whether this is the
 723    * first (non-indented) paragraph.  We "reset" this to true after
 724    * non-paragraphs.
 725    *)
 726   let first_para = ref true in
 727
 728   (* Convert lines to XHTML. *)
 729   let lines =
 730     List.map
 731       (fun st ->
 732          let xhtml =
 733            match st with
 734              | STBlank -> assert false  (* Should never happen. *)
 735              | STParagraph para ->
 736                  markup_paragraph ~first_para:!first_para dbh hostid para
 737              | STHeading (level, text) ->
 738                  markup_heading dbh hostid level text
 739              | STUnnumbered lines ->
 740                  markup_ul dbh hostid lines
 741              | STNumbered lines ->
 742                  markup_ol dbh hostid lines
 743              | STPreformatted lines ->
 744                  markup_pre lines
 745              | STHTML html ->
 746                  let html' = String.concat "\n" html in
 747                  try
 748                    validate html';
 749                    html'
 750                  with
 751                      Invalid_argument msg ->
 752                        let msg = "Invalid HTML: " ^ msg in
 753                        markup_pre (msg :: html) in
 754          first_para := (match st with STParagraph _ -> false | _ -> true);
 755          xhtml
 756       ) lines in
 757
 758   (* Return the lines. *)
 759   String.concat "\n" lines
 760
 761 (* Convert valid XHTML to plain text. *)
 762 let text_re = Pcre.regexp "<[^>]+>"
 763 let text_itempl = Pcre.subst " "
 764
 765 let text_of_xhtml xhtml =
 766   Pcre.replace ~rex:text_re ~itempl:text_itempl xhtml