scripts/wikilib.ml

   1 (* Library of functions useful for people implementing a Wiki.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: wikilib.ml,v 1.1 2004/09/07 10:14:09 rich Exp $
   5  *)
   6
   7 open Apache
   8 open Registry
   9 open Cgi
  10 open Cgi_escape
  11 open Printf
  12
  13 open ExtString
  14
  15 open Merjisforwiki
  16
  17 (* Generate a URL for a new page with the given title.  This code checks
  18  * if the URL already exists in the database and can return one of several
  19  * errors.
  20  *)
  21 type genurl_error_t = GenURL_OK of string
  22                     | GenURL_TooShort
  23                     | GenURL_BadURL
  24                     | GenURL_Duplicate of string
  25
  26 let nontrivial_re = Pcre.regexp ~flags:[`CASELESS] "[a-z0-9]"
  27
  28 let generate_url_of_title (dbh : Dbi.connection) hostid title =
  29   (* Create a suitable URL from this title. *)
  30   let url = String.map (function '\000' .. ' ' | '<' | '>' | '&' | '"' -> '_'
  31                           | c -> Char.lowercase c) title in
  32
  33   (* Check URL is not too trivial. *)
  34   if not (Pcre.pmatch ~rex:nontrivial_re url) then
  35     GenURL_TooShort
  36   (* URL cannot begin with '_'. *)
  37   else if url.[0] = '_' then
  38     GenURL_BadURL
  39   else (
  40     (* Check that the URL doesn't already exist in the database.  If it does
  41      * then it probably means that another page exists with similar enough
  42      * content, so we should redirect to there instead.
  43      *)
  44     let sth = dbh#prepare_cached "select 1 from pages
  45                                    where hostid = ? and url = ?" in
  46     sth#execute [`Int hostid; `String url];
  47
  48     try
  49       sth#fetch1int ();
  50       GenURL_Duplicate url
  51     with
  52         Not_found ->
  53           GenURL_OK url
  54   )
  55
  56 (* Obscure a mailto: URL against spammers. *)
  57 let obscure_mailto url =
  58   if String.length url > 8 then (
  59     let c7 = Char.code url.[7] in
  60     let c8 = Char.code url.[8] in
  61     let start = String.sub url 0 7 in
  62     let rest = escape_html_tag (String.sub url 9 (String.length url - 9)) in
  63     sprintf "%s&#x%02x;&#x%02x;%s" start c7 c8 rest
  64   )
  65   else
  66     url
  67
  68 (* Convert Wiki markup to XHTML 1.0.
  69  *
  70  * Shortcomings:
  71  * Doesn't support multi-level bullet points. (XXX)
  72  * Intra-page links. (XXX)
  73  *)
  74
  75 (* This matches any markup. *)
  76 let markup_re =
  77   let link = "\\[\\[\\s*(?:.+?)\\s*(?:\\|.+?\\s*)?\\]\\]" in
  78   let tag = "</?(?:b|i|strong|em|code|sup|sub|nowiki)>" in
  79   Pcre.regexp ("(.*?)((?:" ^ link ^ ")|(?:" ^ tag ^ "))(.*)")
  80
  81 (* This matches links only, and should be compatible with the link contained
  82  * in the above regexp.
  83  *)
  84 let link_re = Pcre.regexp "\\[\\[\\s*(.+?)\\s*(?:\\|(.+?)\\s*)?\\]\\]"
  85
  86 let image_re =
  87   Pcre.regexp "^(image|thumb(?:nail)?):\\s*([a-z0-9][_a-z0-9]*\\.(?:jpg|jpeg|gif|ico|png))$"
  88 let file_re =
  89   Pcre.regexp "^file:\\s*([a-z0-9][-._a-z0-9]*)$"
  90
  91 let url_re = Pcre.regexp "^[a-z]+://"
  92 let mailto_re = Pcre.regexp "^mailto:"
  93
  94 (* Links. *)
  95 let markup_link dbh hostid link =
  96   let subs = Pcre.exec ~rex:link_re link in
  97   let url = Pcre.get_substring subs 1 in
  98
  99   let tag name = function
 100       `Null -> ""
 101     | `String v -> " " ^ name ^ "=\"" ^ escape_html_tag v ^ "\""
 102   in
 103
 104   if Pcre.pmatch ~rex:image_re url then (
 105     (* It may be an image. *)
 106     let subs = Pcre.exec ~rex:image_re url in
 107     let is_thumb = (Pcre.get_substring subs 1).[0] = 't' in
 108     let name = Pcre.get_substring subs 2 in
 109
 110     let sql = "select id, " ^
 111               (if is_thumb then "tn_width, tn_height"
 112                else "width, height") ^
 113               ", alt, title, longdesc, class
 114                from images
 115               where hostid = ? and name = ?" in
 116     let sth = dbh#prepare_cached sql in
 117     sth#execute [`Int hostid; `String name];
 118
 119     try
 120       let imageid, width, height, alt, title, longdesc, clasz =
 121         match sth#fetch1 () with
 122             [`Int imageid; `Int width; `Int height; `String alt;
 123              (`Null | `String _) as title;
 124              (`Null | `String _) as longdesc;
 125              (`Null | `String _) as clasz] ->
 126               imageid, width, height, alt, title, longdesc, clasz
 127           | _ -> assert false in
 128
 129       let link = "/_image/" ^ escape_url name in
 130
 131       (if is_thumb then "<a href=\"" ^ link ^ "\">" else "") ^
 132       "<img src=\"" ^ link ^ "?version=" ^ string_of_int imageid ^
 133       (if is_thumb then "&thumbnail=1" else "") ^
 134       "\" width=\"" ^
 135       string_of_int width ^
 136       "\" height=\"" ^
 137       string_of_int height ^
 138       "\" alt=\"" ^
 139       escape_html_tag alt ^
 140       "\"" ^
 141       tag "title" title ^
 142       tag "longdesc" longdesc ^
 143       tag "class" clasz ^
 144       "/>" ^
 145       (if is_thumb then "</a>" else "")
 146     with
 147         Not_found ->
 148           (* Image not found. *)
 149           "<a class=\"image_not_found\" " ^
 150           "href=\"/_bin/upload_image_form.cmo?name=" ^
 151           escape_url name ^
 152           "\">" ^
 153           escape_html name ^
 154           "</a>"
 155   ) else if Pcre.pmatch ~rex:file_re url then (
 156     (* It may be a file. *)
 157     let subs = Pcre.exec ~rex:file_re url in
 158     let name = Pcre.get_substring subs 1 in
 159
 160     let sth = dbh#prepare_cached "select title
 161                                     from files
 162                                    where hostid = ? and name = ?" in
 163     sth#execute [`Int hostid; `String name];
 164
 165     try
 166       let title =
 167         match sth#fetch1 () with
 168             [(`Null | `String _) as title] -> title
 169           | _ -> assert false in
 170
 171       "<a href=\"/_file/" ^
 172       escape_url name ^
 173       "\"" ^
 174       tag "title" title ^
 175       ">" ^
 176       escape_html name ^
 177       "</a>"
 178     with
 179         Not_found ->
 180           (* File not found. *)
 181           "<a class=\"file_not_found\" " ^
 182           "href=\"/_bin/upload_file_form.cmo?name=" ^
 183           escape_url name ^
 184           "\">" ^
 185           escape_html name ^
 186           "</a>"
 187   ) else (
 188     (* Pcre changed behaviour between versions.  Previously a non-capture
 189      * would return "".  Now it throws 'Not_found'.
 190      *)
 191     let text =
 192       try Pcre.get_substring subs 2
 193       with Not_found -> "" in
 194     let text = if text = "" then url else text in
 195
 196     (* XXX Escaping here is very hairy indeed.  (See also the obscure_mailto
 197      * function which performs some escaping ...)
 198      *)
 199
 200     let url, clasz, title =
 201       if Pcre.pmatch ~rex:url_re url then
 202         escape_html_tag url, "external", url (* http://.... *)
 203       else if Pcre.pmatch ~rex:mailto_re url then (
 204         obscure_mailto url, "mailto", url
 205       ) else (
 206         let title = url in
 207         (* Look up the 'URL' against the titles in the database and
 208          * obtain the real URL.  If none is found then it's a link to
 209          * create a new page.
 210          *)
 211         let sth = dbh#prepare_cached "select url from pages
 212                                        where hostid = ? and url is not null
 213                                          and lower (title) = lower (?)" in
 214         sth#execute [`Int hostid; `String url];
 215
 216         try
 217           let url = sth#fetch1string () in
 218           "/" ^ url, "internal", title
 219         with
 220             Not_found ->
 221               "/_bin/create_form.cmo?title=" ^ escape_url url, "newpage", title
 222       ) in
 223
 224     "<a href=\"" ^ url ^
 225     "\" class=\"" ^ clasz ^
 226     "\" title=\"" ^ escape_html_tag title ^ "\">" ^
 227     escape_html text ^ "</a>"
 228   )
 229
 230 type find_t = FoundNothing
 231             | FoundOpen of string * string * string
 232             | FoundClose of string * string * string * string
 233             | FoundLink of string * string * string
 234
 235 let _markup_paragraph dbh hostid text =
 236   let find_earliest_markup text =
 237     let convert_b_and_i elem =
 238       if elem = "b" then "strong"
 239       else if elem = "i" then "em"
 240       else elem
 241     in
 242
 243     try
 244       let subs = Pcre.exec ~rex:markup_re text in
 245       let first = Pcre.get_substring subs 1 in
 246       let markup = Pcre.get_substring subs 2 in
 247       let rest = Pcre.get_substring subs 3 in
 248       if String.length markup > 2 &&
 249         markup.[0] = '[' && markup.[1] = '[' then (
 250           let link = markup_link dbh hostid markup in
 251           FoundLink (first, link, rest)
 252         )
 253       else if String.length markup > 2 &&
 254         markup.[0] = '<' && markup.[1] = '/' then (
 255           let elem = String.sub markup 2 (String.length markup - 3) in
 256           let elem = convert_b_and_i elem in
 257           FoundClose (first, elem, rest, markup ^ rest)
 258         )
 259       else if String.length markup > 1 && markup.[0] = '<' then (
 260         let elem = String.sub markup 1 (String.length markup - 2) in
 261         let elem = convert_b_and_i elem in
 262         FoundOpen (first, elem, rest)
 263       )
 264       else
 265         failwith ("bad regexp: markup is '" ^ markup ^ "'");
 266     with
 267         Not_found -> FoundNothing
 268   in
 269
 270   (* This code performs markup for a "paragraph" unit.  The strategy
 271    * is to look for the next matching markup or link, process that, and
 272    * then continue recursively with the remainder of the string.  We also
 273    * maintain a stack which is our current level of nesting of <b>-like
 274    * operators.
 275    *)
 276   let rec loop = function
 277     | "", [] -> [""]                    (* base case *)
 278
 279     | text, ("nowiki" :: stack) ->
 280         (*prerr_endline ("nowiki case: text = " ^ text);*)
 281
 282         (* If the top of the stack is <nowiki> then we're just looking for
 283          * the closing </nowiki>, and nothing else matters. *)
 284         (match Pcre.split ~pat:"</nowiki>" ~max:2 text with
 285            | [] -> loop ("", stack)
 286            | [x] -> escape_html x :: loop ("", stack)
 287            | [x;y] -> escape_html x :: loop (y, stack)
 288            | _ -> assert false)
 289
 290     | "", (x :: xs) ->                  (* base case, popping the stack *)
 291         "</" :: x :: ">" :: loop ("", xs)
 292
 293     | text, [] ->
 294         (*prerr_endline ("text = " ^ text ^ ", stack empty");*)
 295
 296         (* Look for the earliest possible matching markup.  Because the
 297          * stack is empty, we're not looking for closing tags.
 298          *)
 299         (match find_earliest_markup text with
 300            | FoundNothing -> escape_html text :: []
 301            | FoundClose (first, elem, rest, _) ->
 302                (* close tags ignored *)
 303                escape_html first :: "&lt;/" :: escape_html elem :: "&gt;" ::
 304                  loop (rest, [])
 305            | FoundOpen (first, elem, rest) when elem = "nowiki" ->
 306                (* handle <nowiki> specially ... *)
 307                escape_html first :: loop (rest, elem :: [])
 308            | FoundOpen (first, elem, rest) ->
 309                (* open tag - push it onto the stack *)
 310                escape_html first :: "<" :: elem :: ">" :: loop (rest, [elem])
 311            | FoundLink (first, link, rest) ->
 312                escape_html first :: link :: loop (rest, [])
 313         )
 314
 315     | text, ((x :: xs) as stack) ->
 316         (*prerr_endline ("text = " ^ text ^ ", top of stack = " ^ x ^
 317           ", stack size = " ^ string_of_int (List.length stack));*)
 318
 319         (* Look for the earliest possible matching markup. *)
 320         (match find_earliest_markup text with
 321            | FoundNothing -> escape_html text :: loop ("", stack)
 322            | FoundClose (first, elem, rest, _) when x = elem ->
 323                (* matching close tag *)
 324                escape_html first :: "</" :: elem :: ">" :: loop (rest, xs)
 325            | FoundClose (first, elem, rest, elem_rest) ->
 326                (* non-matching close tag *)
 327                escape_html first :: "</" :: x :: ">" :: loop (elem_rest, xs)
 328            | FoundOpen (first, elem, rest) when elem = "nowiki" ->
 329                (* handle <nowiki> specially ... *)
 330                escape_html first :: loop (rest, elem :: stack)
 331            | FoundOpen (first, elem, rest) ->
 332                (* open tag - push it onto the stack *)
 333                escape_html first :: "<" :: elem :: ">" ::
 334                  loop (rest, elem :: stack)
 335            | FoundLink (first, link, rest) ->
 336                (* pop everything off the stack first *)
 337                escape_html first :: loop ("", stack) @ link :: loop (rest, [])
 338         )
 339   in
 340
 341   (*prerr_endline ("original markup = " ^ text);*)
 342   let text = loop (text, []) in
 343   let text = String.concat "" text in
 344   (*prerr_endline ("after loop = " ^ text);*)
 345   text
 346
 347 let markup_paragraph dbh hostid text =
 348   "<p>" ^ _markup_paragraph dbh hostid text ^ "</p>"
 349
 350 let markup_heading dbh hostid level text =
 351   let text = _markup_paragraph dbh hostid text in
 352   sprintf "<h%d>%s</h%d>" level text level
 353
 354 let markup_ul dbh hostid lines =
 355   "<ul><li>" ^
 356   String.concat "</li>\n<li>"
 357     (List.map (fun t -> _markup_paragraph dbh hostid t) lines) ^
 358   "</li></ul>"
 359
 360 let markup_ol dbh hostid lines =
 361   "<ol><li>" ^
 362   String.concat "</li>\n<li>"
 363     (List.map (fun t -> _markup_paragraph dbh hostid t) lines) ^
 364   "</li></ol>"
 365
 366 let markup_pre lines =
 367   "<pre>\n" ^
 368   String.concat "\n" (List.map Cgi_escape.escape_html lines) ^
 369   "\n</pre>\n"
 370
 371
 372 type line_t = STBlank
 373             | STHeading of int * string (* <h3>, <h4>, ... *)
 374             | STUnnumbered of string list (* <ul> *)
 375             | STNumbered of string list (* <ol> *)
 376             | STPreformatted of string list (* <pre> *)
 377             | STParagraph of string     (* Ordinary <p> *)
 378
 379 let split_lines_re = Pcre.regexp "\\r?\\n"
 380 let blank_re = Pcre.regexp "^\\s*$"
 381 let heading_re = Pcre.regexp "^(=+)\\s+(.*)"
 382 let unnumbered_re = Pcre.regexp "^(\\*)\\s+(.*)"
 383 let numbered_re = Pcre.regexp "^(\\#)\\s+(.*)"
 384 let preformatted_re = Pcre.regexp "^ (.*)"
 385
 386 let xhtml_of_content (dbh : Dbi.connection) hostid text =
 387   (* Split the text into lines. *)
 388   let lines = Pcre.split ~rex:split_lines_re text in
 389   (* Iterate over the lines to isolate headers and paragraphs. *)
 390   let lines =
 391     List.map
 392       (fun line ->
 393          if Pcre.pmatch ~rex:preformatted_re line then (
 394            let subs = Pcre.exec ~rex:preformatted_re line in
 395            let line = Pcre.get_substring subs 1 in
 396            STPreformatted [line]
 397          )
 398          else if Pcre.pmatch ~rex:blank_re line then
 399            STBlank
 400          else if Pcre.pmatch ~rex:heading_re line then (
 401            let subs = Pcre.exec ~rex:heading_re line in
 402            let count = String.length (Pcre.get_substring subs 1) + 2 in
 403            let line = Pcre.get_substring subs 2 in
 404            STHeading (count, line)
 405          )
 406          else if Pcre.pmatch ~rex:unnumbered_re line then (
 407            let subs = Pcre.exec ~rex:unnumbered_re line in
 408            let line = Pcre.get_substring subs 2 in
 409            STUnnumbered [line]
 410          )
 411          else if Pcre.pmatch ~rex:numbered_re line then (
 412            let subs = Pcre.exec ~rex:numbered_re line in
 413            let line = Pcre.get_substring subs 2 in
 414            STNumbered [line]
 415          ) else
 416            STParagraph line) lines in
 417
 418   (* Aggregate paragraphs and lists. *)
 419   let rec loop = function
 420       [] -> []
 421     | STHeading (_, _) as h :: xs ->
 422         h :: loop xs
 423     | STUnnumbered lines1 :: STUnnumbered lines2 :: xs ->
 424         loop (STUnnumbered (lines1 @ lines2) :: xs)
 425     | STUnnumbered lines :: xs ->
 426         STUnnumbered lines :: loop xs
 427     | STNumbered lines1 :: STNumbered lines2 :: xs ->
 428         loop (STNumbered (lines1 @ lines2) :: xs)
 429     | STNumbered lines :: xs ->
 430         STNumbered lines :: loop xs
 431     | STPreformatted lines1 :: STPreformatted lines2 :: xs ->
 432         loop (STPreformatted (lines1 @ lines2) :: xs)
 433     | STPreformatted lines :: xs ->
 434         STPreformatted lines :: loop xs
 435     | STParagraph line1 :: STParagraph line2 :: xs ->
 436         loop (STParagraph (line1 ^ " " ^ line2) :: xs)
 437     | STParagraph line :: xs ->
 438         STParagraph line :: loop xs
 439     | STBlank :: xs ->
 440         loop xs
 441   in
 442   let lines = loop lines in
 443
 444   (* Convert lines to XHTML. *)
 445   let lines =
 446     List.map
 447       (function
 448            STBlank -> assert false    (* Should never happen. *)
 449          | STParagraph para ->
 450              markup_paragraph dbh hostid para
 451          | STHeading (level, text) ->
 452              markup_heading dbh hostid level text
 453          | STUnnumbered lines ->
 454              markup_ul dbh hostid lines
 455          | STNumbered lines ->
 456              markup_ol dbh hostid lines
 457          | STPreformatted lines ->
 458              markup_pre lines
 459       ) lines in
 460
 461   (* Return the lines. *)
 462   String.concat "\n" lines
 463
 464 (* Convert valid XHTML to plain text. *)
 465 let text_re = Pcre.regexp "<[^>]+>"
 466 let text_itempl = Pcre.subst " "
 467
 468 let text_of_xhtml xhtml =
 469   Pcre.replace ~rex:text_re ~itempl:text_itempl xhtml