(* Library of functions useful for people implementing a Wiki.
 * Written by Richard W.M. Jones <rich@merjis.com>.
 * Copyright (C) 2004 Merjis Ltd.
 * $Id: wikilib.ml,v 1.2 2004/09/07 14:58:34 rich Exp $
 *)

open Apache
open Registry
open Cgi
open Cgi_escape
open Printf

open ExtString

(* Generate a URL for a new page with the given title.  This code checks
 * if the URL already exists in the database and can return one of several
 * errors.
 *)
type genurl_error_t = GenURL_OK of string
		    | GenURL_TooShort
		    | GenURL_BadURL
		    | GenURL_Duplicate of string

let nontrivial_re = Pcre.regexp ~flags:[`CASELESS] "[a-z0-9]"

let generate_url_of_title (dbh : Dbi.connection) hostid title =
  (* Create a suitable URL from this title. *)
  let url = String.map (function '\000' .. ' ' | '<' | '>' | '&' | '"' -> '_'
			  | c -> Char.lowercase c) title in

  (* Check URL is not too trivial. *)
  if not (Pcre.pmatch ~rex:nontrivial_re url) then
    GenURL_TooShort
  (* URL cannot begin with '_'. *)
  else if url.[0] = '_' then
    GenURL_BadURL
  else (
    (* Check that the URL doesn't already exist in the database.  If it does
     * then it probably means that another page exists with similar enough
     * content, so we should redirect to there instead.
     *)
    let sth = dbh#prepare_cached "select 1 from pages
                                   where hostid = ? and url = ?" in
    sth#execute [`Int hostid; `String url];

    try
      sth#fetch1int ();
      GenURL_Duplicate url
    with
	Not_found ->
	  GenURL_OK url
  )

(* Obscure a mailto: URL against spammers. *)
let obscure_mailto url =
  if String.length url > 8 then (
    let c7 = Char.code url.[7] in
    let c8 = Char.code url.[8] in
    let start = String.sub url 0 7 in
    let rest = escape_html_tag (String.sub url 9 (String.length url - 9)) in
    sprintf "%s&#x%02x;&#x%02x;%s" start c7 c8 rest
  )
  else
    url

(* Convert Wiki markup to XHTML 1.0.
 *
 * Shortcomings:
 * Doesn't support multi-level bullet points. (XXX)
 * Intra-page links. (XXX)
 *)

(* This matches any markup. *)
let markup_re =
  let link = "\\[\\[\\s*(?:.+?)\\s*(?:\\|.+?\\s*)?\\]\\]" in
  let tag = "</?(?:b|i|strong|em|code|sup|sub|nowiki)>" in
  Pcre.regexp ("(.*?)((?:" ^ link ^ ")|(?:" ^ tag ^ "))(.*)")

(* This matches links only, and should be compatible with the link contained
 * in the above regexp.
 *)
let link_re = Pcre.regexp "\\[\\[\\s*(.+?)\\s*(?:\\|(.+?)\\s*)?\\]\\]"

let image_re =
  Pcre.regexp "^(image|thumb(?:nail)?):\\s*([a-z0-9][_a-z0-9]*\\.(?:jpg|jpeg|gif|ico|png))$"
let file_re =
  Pcre.regexp "^file:\\s*([a-z0-9][-._a-z0-9]*)$"

let url_re = Pcre.regexp "^[a-z]+://"
let mailto_re = Pcre.regexp "^mailto:"

(* Links. *)
let markup_link dbh hostid link =
  let subs = Pcre.exec ~rex:link_re link in
  let url = Pcre.get_substring subs 1 in

  let tag name = function
      `Null -> ""
    | `String v -> " " ^ name ^ "=\"" ^ escape_html_tag v ^ "\""
  in

  if Pcre.pmatch ~rex:image_re url then (
    (* It may be an image. *)
    let subs = Pcre.exec ~rex:image_re url in
    let is_thumb = (Pcre.get_substring subs 1).[0] = 't' in
    let name = Pcre.get_substring subs 2 in

    let sql = "select id, " ^
	      (if is_thumb then "tn_width, tn_height"
	       else "width, height") ^
	      ", alt, title, longdesc, class
               from images
              where hostid = ? and name = ?" in
    let sth = dbh#prepare_cached sql in
    sth#execute [`Int hostid; `String name];

    try
      let imageid, width, height, alt, title, longdesc, clasz =
	match sth#fetch1 () with
	    [`Int imageid; `Int width; `Int height; `String alt;
	     (`Null | `String _) as title;
	     (`Null | `String _) as longdesc;
	     (`Null | `String _) as clasz] ->
	      imageid, width, height, alt, title, longdesc, clasz
	  | _ -> assert false in

      let link = "/_image/" ^ escape_url name in

      (if is_thumb then "<a href=\"" ^ link ^ "\">" else "") ^
      "<img src=\"" ^ link ^ "?version=" ^ string_of_int imageid ^
      (if is_thumb then "&thumbnail=1" else "") ^
      "\" width=\"" ^
      string_of_int width ^
      "\" height=\"" ^
      string_of_int height ^
      "\" alt=\"" ^
      escape_html_tag alt ^
      "\"" ^
      tag "title" title ^
      tag "longdesc" longdesc ^
      tag "class" clasz ^
      "/>" ^
      (if is_thumb then "</a>" else "")
    with
	Not_found ->
	  (* Image not found. *)
	  "<a class=\"image_not_found\" " ^
	  "href=\"/_bin/upload_image_form.cmo?name=" ^
	  escape_url name ^
	  "\">" ^
	  escape_html name ^
	  "</a>"
  ) else if Pcre.pmatch ~rex:file_re url then (
    (* It may be a file. *)
    let subs = Pcre.exec ~rex:file_re url in
    let name = Pcre.get_substring subs 1 in

    let sth = dbh#prepare_cached "select title
                                    from files
                                   where hostid = ? and name = ?" in
    sth#execute [`Int hostid; `String name];

    try
      let title =
	match sth#fetch1 () with
	    [(`Null | `String _) as title] -> title
	  | _ -> assert false in

      "<a href=\"/_file/" ^
      escape_url name ^
      "\"" ^
      tag "title" title ^
      ">" ^
      escape_html name ^
      "</a>"
    with
	Not_found ->
	  (* File not found. *)
	  "<a class=\"file_not_found\" " ^
	  "href=\"/_bin/upload_file_form.cmo?name=" ^
	  escape_url name ^
	  "\">" ^
	  escape_html name ^
	  "</a>"
  ) else (
    (* Pcre changed behaviour between versions.  Previously a non-capture
     * would return "".  Now it throws 'Not_found'.
     *)
    let text =
      try Pcre.get_substring subs 2
      with Not_found -> "" in
    let text = if text = "" then url else text in

    (* XXX Escaping here is very hairy indeed.  (See also the obscure_mailto
     * function which performs some escaping ...)
     *)

    let url, clasz, title =
      if Pcre.pmatch ~rex:url_re url then
	escape_html_tag url, "external", url (* http://.... *)
      else if Pcre.pmatch ~rex:mailto_re url then (
	obscure_mailto url, "mailto", url
      ) else (
	let title = url in
	(* Look up the 'URL' against the titles in the database and
	 * obtain the real URL.  If none is found then it's a link to
	 * create a new page.
	 *)
	let sth = dbh#prepare_cached "select url from pages
                                       where hostid = ? and url is not null
                                         and lower (title) = lower (?)" in
	sth#execute [`Int hostid; `String url];

	try
	  let url = sth#fetch1string () in
	  "/" ^ url, "internal", title
	with
	    Not_found ->
	      "/_bin/create_form.cmo?title=" ^ escape_url url, "newpage", title
      ) in

    "<a href=\"" ^ url ^
    "\" class=\"" ^ clasz ^
    "\" title=\"" ^ escape_html_tag title ^ "\">" ^
    escape_html text ^ "</a>"
  )

type find_t = FoundNothing
	    | FoundOpen of string * string * string
            | FoundClose of string * string * string * string
	    | FoundLink of string * string * string

let _markup_paragraph dbh hostid text =
  let find_earliest_markup text =
    let convert_b_and_i elem =
      if elem = "b" then "strong"
      else if elem = "i" then "em"
      else elem
    in

    try
      let subs = Pcre.exec ~rex:markup_re text in
      let first = Pcre.get_substring subs 1 in
      let markup = Pcre.get_substring subs 2 in
      let rest = Pcre.get_substring subs 3 in
      if String.length markup > 2 &&
	markup.[0] = '[' && markup.[1] = '[' then (
	  let link = markup_link dbh hostid markup in
	  FoundLink (first, link, rest)
	)
      else if String.length markup > 2 &&
	markup.[0] = '<' && markup.[1] = '/' then (
	  let elem = String.sub markup 2 (String.length markup - 3) in
	  let elem = convert_b_and_i elem in
	  FoundClose (first, elem, rest, markup ^ rest)
	)
      else if String.length markup > 1 && markup.[0] = '<' then (
	let elem = String.sub markup 1 (String.length markup - 2) in
	let elem = convert_b_and_i elem in
	FoundOpen (first, elem, rest)
      )
      else
	failwith ("bad regexp: markup is '" ^ markup ^ "'");
    with
	Not_found -> FoundNothing
  in

  (* This code performs markup for a "paragraph" unit.  The strategy
   * is to look for the next matching markup or link, process that, and
   * then continue recursively with the remainder of the string.  We also
   * maintain a stack which is our current level of nesting of <b>-like
   * operators.
   *)
  let rec loop = function
    | "", [] -> [""]			(* base case *)

    | text, ("nowiki" :: stack) ->
	(*prerr_endline ("nowiki case: text = " ^ text);*)

	(* If the top of the stack is <nowiki> then we're just looking for
	 * the closing </nowiki>, and nothing else matters. *)
	(match Pcre.split ~pat:"</nowiki>" ~max:2 text with
	   | [] -> loop ("", stack)
	   | [x] -> escape_html x :: loop ("", stack)
	   | [x;y] -> escape_html x :: loop (y, stack)
	   | _ -> assert false)

    | "", (x :: xs) ->			(* base case, popping the stack *)
	"</" :: x :: ">" :: loop ("", xs)

    | text, [] ->
	(*prerr_endline ("text = " ^ text ^ ", stack empty");*)

	(* Look for the earliest possible matching markup.  Because the
	 * stack is empty, we're not looking for closing tags.
	 *)
	(match find_earliest_markup text with
	   | FoundNothing -> escape_html text :: []
	   | FoundClose (first, elem, rest, _) ->
	       (* close tags ignored *)
	       escape_html first :: "&lt;/" :: escape_html elem :: "&gt;" ::
		 loop (rest, [])
	   | FoundOpen (first, elem, rest) when elem = "nowiki" ->
	       (* handle <nowiki> specially ... *)
	       escape_html first :: loop (rest, elem :: [])
	   | FoundOpen (first, elem, rest) ->
	       (* open tag - push it onto the stack *)
	       escape_html first :: "<" :: elem :: ">" :: loop (rest, [elem])
	   | FoundLink (first, link, rest) ->
	       escape_html first :: link :: loop (rest, [])
	)

    | text, ((x :: xs) as stack) ->
	(*prerr_endline ("text = " ^ text ^ ", top of stack = " ^ x ^
	  ", stack size = " ^ string_of_int (List.length stack));*)

	(* Look for the earliest possible matching markup. *)
	(match find_earliest_markup text with
	   | FoundNothing -> escape_html text :: loop ("", stack)
	   | FoundClose (first, elem, rest, _) when x = elem ->
	       (* matching close tag *)
	       escape_html first :: "</" :: elem :: ">" :: loop (rest, xs)
	   | FoundClose (first, elem, rest, elem_rest) ->
	       (* non-matching close tag *)
	       escape_html first :: "</" :: x :: ">" :: loop (elem_rest, xs)
	   | FoundOpen (first, elem, rest) when elem = "nowiki" ->
	       (* handle <nowiki> specially ... *)
	       escape_html first :: loop (rest, elem :: stack)
	   | FoundOpen (first, elem, rest) ->
	       (* open tag - push it onto the stack *)
	       escape_html first :: "<" :: elem :: ">" ::
		 loop (rest, elem :: stack)
	   | FoundLink (first, link, rest) ->
	       (* pop everything off the stack first *)
	       escape_html first :: loop ("", stack) @ link :: loop (rest, [])
	)
  in

  (*prerr_endline ("original markup = " ^ text);*)
  let text = loop (text, []) in
  let text = String.concat "" text in
  (*prerr_endline ("after loop = " ^ text);*)
  text

let markup_paragraph dbh hostid text =
  "<p>" ^ _markup_paragraph dbh hostid text ^ "</p>"

let markup_heading dbh hostid level text =
  let text = _markup_paragraph dbh hostid text in
  sprintf "<h%d>%s</h%d>" level text level

let markup_ul dbh hostid lines =
  "<ul><li>" ^
  String.concat "</li>\n<li>"
    (List.map (fun t -> _markup_paragraph dbh hostid t) lines) ^
  "</li></ul>"

let markup_ol dbh hostid lines =
  "<ol><li>" ^
  String.concat "</li>\n<li>"
    (List.map (fun t -> _markup_paragraph dbh hostid t) lines) ^
  "</li></ol>"

let markup_pre lines =
  "<pre>\n" ^
  String.concat "\n" (List.map Cgi_escape.escape_html lines) ^
  "\n</pre>\n"


type line_t = STBlank
	    | STHeading of int * string	(* <h3>, <h4>, ... *)
	    | STUnnumbered of string list (* <ul> *)
	    | STNumbered of string list	(* <ol> *)
	    | STPreformatted of string list (* <pre> *)
	    | STParagraph of string	(* Ordinary <p> *)

let split_lines_re = Pcre.regexp "\\r?\\n"
let blank_re = Pcre.regexp "^\\s*$"
let heading_re = Pcre.regexp "^(=+)\\s+(.*)"
let unnumbered_re = Pcre.regexp "^(\\*)\\s+(.*)"
let numbered_re = Pcre.regexp "^(\\#)\\s+(.*)"
let preformatted_re = Pcre.regexp "^ (.*)"

let xhtml_of_content (dbh : Dbi.connection) hostid text =
  (* Split the text into lines. *)
  let lines = Pcre.split ~rex:split_lines_re text in
  (* Iterate over the lines to isolate headers and paragraphs. *)
  let lines =
    List.map
      (fun line ->
	 if Pcre.pmatch ~rex:preformatted_re line then (
	   let subs = Pcre.exec ~rex:preformatted_re line in
	   let line = Pcre.get_substring subs 1 in
	   STPreformatted [line]
	 )
         else if Pcre.pmatch ~rex:blank_re line then
           STBlank
         else if Pcre.pmatch ~rex:heading_re line then (
           let subs = Pcre.exec ~rex:heading_re line in
           let count = String.length (Pcre.get_substring subs 1) + 2 in
           let line = Pcre.get_substring subs 2 in
           STHeading (count, line)
         )
         else if Pcre.pmatch ~rex:unnumbered_re line then (
           let subs = Pcre.exec ~rex:unnumbered_re line in
           let line = Pcre.get_substring subs 2 in
           STUnnumbered [line]
         )
         else if Pcre.pmatch ~rex:numbered_re line then (
           let subs = Pcre.exec ~rex:numbered_re line in
           let line = Pcre.get_substring subs 2 in
           STNumbered [line]
         ) else
           STParagraph line) lines in

  (* Aggregate paragraphs and lists. *)
  let rec loop = function
      [] -> []
    | STHeading (_, _) as h :: xs ->
        h :: loop xs
    | STUnnumbered lines1 :: STUnnumbered lines2 :: xs ->
        loop (STUnnumbered (lines1 @ lines2) :: xs)
    | STUnnumbered lines :: xs ->
        STUnnumbered lines :: loop xs
    | STNumbered lines1 :: STNumbered lines2 :: xs ->
        loop (STNumbered (lines1 @ lines2) :: xs)
    | STNumbered lines :: xs ->
        STNumbered lines :: loop xs
    | STPreformatted lines1 :: STPreformatted lines2 :: xs ->
        loop (STPreformatted (lines1 @ lines2) :: xs)
    | STPreformatted lines :: xs ->
        STPreformatted lines :: loop xs
    | STParagraph line1 :: STParagraph line2 :: xs ->
        loop (STParagraph (line1 ^ " " ^ line2) :: xs)
    | STParagraph line :: xs ->
        STParagraph line :: loop xs
    | STBlank :: xs ->
        loop xs
  in
  let lines = loop lines in

  (* Convert lines to XHTML. *)
  let lines =
    List.map
      (function
           STBlank -> assert false    (* Should never happen. *)
         | STParagraph para ->
             markup_paragraph dbh hostid para
         | STHeading (level, text) ->
             markup_heading dbh hostid level text
         | STUnnumbered lines ->
             markup_ul dbh hostid lines
         | STNumbered lines ->
             markup_ol dbh hostid lines
	 | STPreformatted lines ->
	     markup_pre lines
      ) lines in

  (* Return the lines. *)
  String.concat "\n" lines

(* Convert valid XHTML to plain text. *)
let text_re = Pcre.regexp "<[^>]+>"
let text_itempl = Pcre.subst " "

let text_of_xhtml xhtml =
  Pcre.replace ~rex:text_re ~itempl:text_itempl xhtml