(* COCANWIKI - a wiki written in Objective CAML.
 * Written by Richard W.M. Jones <rich@merjis.com>.
 * Copyright (C) 2004 Merjis Ltd.
 * $Id: edit.ml,v 1.19 2004/10/10 16:14:43 rich Exp $
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; see the file COPYING.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 * Boston, MA 02111-1307, USA.
 *)

open Apache
open Registry
open Cgi
open Printf

open ExtString

open Cocanwiki
open Cocanwiki_template
open Cocanwiki_ok
open Cocanwiki_emailnotify
open Cocanwiki_diff
open Cocanwiki_strings

(* Page of title. *)
type pt_t = Page of string | Title of string

(* We keep an "internal model" of the page - see build_internal_model ()
 * below.
 *)
type model_t = {
  id : int;				(* Original page ID (0 = none). *)
  pt : pt_t;				(* Page of title (only used if id=0) *)
  description : string;			(* Description. *)
  redirect : string;			(* Redirect to ("" = none). *)
  contents : (string * string * string) list;
					(* (sectionname, divname, content)
					 * for each section. *)
}

let run r (q : cgi) (dbh : Dbi.connection) hostid {hostname = hostname} user =
  let template = get_template dbh hostid "edit.html" in
  let template_conflict = get_template dbh hostid "edit_conflict.html" in
  let template_email = get_template dbh hostid "edit_page_email.txt" in

  (* Workaround bugs in IE, specifically lack of support for <button>
   * elements.
   *)
  let msie =
    try
      let ua = Table.get (Request.headers_in r) "User-Agent" in
      ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
      true
    with
	Not_found | String.Invalid_string -> false in
  template#conditional "msie" msie;

  (* Build the internal model from the parameters passed to the script. *)
  let build_internal_model () =
    let id = int_of_string (q#param "id") in
    let description = q#param "description" in
    let redirect = q#param "redirect" in
    let pt = match q#param "pt_type" with
	"page" -> Page (q#param "pt_value")
      | "title" -> Title (q#param "pt_value")
      | _ -> failwith "unknown value for pt_type parameter" in

    let contents = ref [] in
    let i = ref 1 in
    while q#param_exists ("content_" ^ string_of_int !i) do
      let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
      let content = q#param ("content_" ^ string_of_int !i) in
      let divname = q#param ("divname_" ^ string_of_int !i) in
      contents := (sectionname, divname, content) :: !contents;
      incr i
    done;
    let contents = List.rev !contents in

    { id = id;
      pt = pt;
      description = description;
      redirect = redirect;
      contents = contents; }
  in

  (* Check for errors in the model. *)
  let check_for_errors model =
    let errors = ref [] in
    let add_error msg = errors := msg :: !errors in
    let get_errors () = List.rev !errors in

    if model.redirect = "" then (
      (* Empty page? *)
      if model.contents = [] then
	add_error ("This page is empty.  Use 'Insert new section here' " ^
		   "to write something!");

      (* Description field? *)
      if model.description = "" then
	add_error ("The description field is very important!  This field is " ^
                   "used by search engines and directories to describe " ^
                   "what's on this page.");
    )
    else (* it's a redirect *) (
      (* Redirect points to a real page? *)
      let sth = dbh#prepare_cached "select 1 from pages
                                     where hostid = ?
                                       and url is not null
                                       and url = ?
                                       and id <> ?
                                       and redirect is null" in
      sth#execute [`Int hostid; `String model.redirect; `Int model.id];

      let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
      if not ok then
	add_error ("Redirect must point to an ordinary page " ^
		   "(ie. not to a page which is itself a redirect).")
    );

    (* All sections after the first one have sectionnames?  The first
     * section ONLY is allowed to have an empty title.
     *)
    if model.contents <> [] then
      List.iter (function (sectionnames, _, _)
		     when string_is_whitespace sectionnames ->
		       add_error
		       ("Every section except the first must have a title.");
		   | _ -> ())
	(List.tl model.contents);

    get_errors ()
  in

  (* Various "actions" that can be performed on the model. *)
  let action_insert model posn item =
    (* posn = 0 means insert before the first element of the current list. *)
    let rec loop =
      function
          0, xs -> item :: xs
        | _, [] -> [ item ]
        | n, x :: xs -> x :: (loop (n-1, xs))
    in
    let contents = loop (posn, model.contents) in
    { model with contents = contents }
  in
  let action_moveup model posn =
    (* posn = 1 means move up the first element, ie. do nothing
     * posn = 2 means move up the second element to the first position
     * etc.
     *)
    let rec loop =
      function
          0, xs
        | 1, xs -> xs
        | _, [] -> []
        | 2, x :: y :: xs -> y :: x :: xs
        | n, x :: xs -> x :: (loop (n-1, xs))
    in
    let contents = loop (posn, model.contents) in
    { model with contents = contents }
  in
  let action_movedn model posn =
    (* posn = 1 means move down the first element to the second position
     * etc.
     *)
    let rec loop =
      function
          0, xs -> xs
        | _, [] -> []
        | 1, x :: y :: xs -> y :: x :: xs
        | n, x :: xs -> x :: (loop (n-1, xs))
    in
    let contents = loop (posn, model.contents) in
    { model with contents = contents }
  in
  let action_delete model posn =
    (* posn = 1 means delete the first element *)
    let rec loop =
      function
          0, xs -> xs
        | _, [] -> []
        | 1, x :: xs -> xs
        | n, x :: xs -> x :: (loop (n-1, xs))
    in
    let contents = loop (posn, model.contents) in
    { model with contents = contents }
  in

  (* Convert model to template. *)
  let model_to_template model template =
    template#set "id" (string_of_int model.id);
    template#set "description" model.description;

    (match model.pt with
	 Page page ->
	   template#set "pt_type" "page";
	   template#set "pt_value" page
       | Title title ->
	   template#set "pt_type" "title";
	   template#set "pt_value" title);

    (* Redirects table. *)
    let sth = dbh#prepare_cached "select url, title from pages
                                   where url is not null
                                     and redirect is null
                                     and hostid = ? and id <> ?
                                   order by 2" in
    sth#execute [`Int hostid; `Int model.id];
    let table = sth#map (function [`String url; `String title] ->
			   let selected = model.redirect = url in
			   [ "url", Template.VarString url;
			     "title", Template.VarString title;
			     "selected", Template.VarConditional selected ]
			   | _ -> assert false) in
    template#table "redirects" table;

    if model.id <> 0 then (
      (* Need to go to the database to get the title of the page ... *)
      let sth = dbh#prepare_cached "select title from pages
                                     where hostid = ? and id = ?" in
      sth#execute [`Int hostid; `Int model.id];
      let title = sth#fetch1string () in
      template#set "title" title;
    ) else (
      match model.pt with
	  Page page -> template#set "title" page
	| Title title -> template#set "title" title
    );

    let ordering = ref 0 in
    let table =
      List.map
	(fun (sectionname, divname, content) ->
	   incr ordering; let ordering = !ordering in
	   [ "ordering", Template.VarString (string_of_int ordering);
	     "sectionname", Template.VarString sectionname;
	     "divname", Template.VarString divname;
	     "content", Template.VarString content ]) model.contents in
    template#table "contents" table;

    (* Check for errors and put those into the template. *)
    let errors = check_for_errors model in
    let errors = List.map (fun msg ->
			     [ "error", Template.VarString msg ]) errors in
    template#table "errors" errors;
    template#conditional "has_errors" (errors <> [])
  in

  (* Check if a URL exists in the database. *)
  let page_exists page =
    let sth =
      dbh#prepare_cached "select 1 from pages where hostid = ? and url = ?" in
    sth#execute [`Int hostid; `String page];

    try sth#fetch1int () = 1 with Not_found -> false
  in

  (* Begin editing a page, pulling the page out of the database and building
   * a model from it.
   *)
  let begin_editing page =
    (* Pull out the page itself from the database. *)
    let sth = dbh#prepare_cached "select id, title, description,
                                         coalesce (redirect, '')
                                    from pages
                                   where hostid = ? and url = ?" in
    sth#execute [`Int hostid; `String page];

    let pageid, title, description, redirect =
      match sth#fetch1 () with
	  [`Int pageid; `String title; `String description; `String redirect]->
	    pageid, title, description, redirect
	| _ -> assert false in

    (* Get the sections. *)
    let sth = dbh#prepare_cached "select coalesce (sectionname, ''),
                                         content,
                                         coalesce (divname, '')
                                    from contents
                                   where pageid = ?
                                   order by ordering" in
    sth#execute [`Int pageid];

    let contents =
      sth#map (function
		 | [`String sectionname; `String content; `String divname] ->
		     sectionname, divname, content
		 | _ -> assert false) in

    let model = { id = pageid;
		  pt = Page page;
		  description = description;
		  redirect = redirect;
		  contents = contents; } in

    model_to_template model template
  in

  (* Begin editing with a blank page, typically a template. *)
  let begin_editing_new pt =
    let url, title =
      match pt with
	  Page url -> url, url
	| Title title ->
	    match Wikilib.generate_url_of_title dbh hostid title with
		Wikilib.GenURL_OK url -> url, title
	      | Wikilib.GenURL_Duplicate url ->
		  q#redirect ("http://" ^ hostname ^ "/" ^ url);
		  return ()
	      | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
		  error ~back_button:true ~title:"Bad page name"
		    q "The page name supplied is too short or invalid.";
		  return () in

    (* Initial page contents. *)
    let contents =
      match pt with
	  Page url -> []
	| Title title ->
	    [ "", "",
	      "<b>" ^ title ^ "</b> is " ] in

    let model = { id = 0;
		  pt = pt;
		  description = title;
		  redirect = "";
		  contents = contents } in

    model_to_template model template
  in

  let continue_editing () =
    let model = ref (build_internal_model ()) in

    (* An "action" parameter? *)
    let is_action, get_action =
      let actions = q#params in
      (* Don't actually care about the value fields ... *)
      let actions = List.map (fun (str, _) -> str) actions in
      (* Some of our actions are imagemaps, so parameters like name.x, name.y
       * need to be changed to name and have resulting duplicates removed.
       *)
      let actions =
	List.filter (fun str ->
		       String.length str > 7 &&
		       String.sub str 0 7 = "action_" &&
		       not (String.ends_with str ".y")) actions in
      let actions =
	List.map (fun str ->
		    if String.ends_with str ".x" then (
		      let str = String.sub str 0 (String.length str - 2) in
		      str
		    )
		    else str) actions in
      let actions =
	List.map (fun str ->
		    let action_type = String.sub str 7 6 in
		    let action_value =
		      String.sub str 14 (String.length str - 14) in
		    let action_value = int_of_string action_value in
		    action_type, action_value) actions in

      let is_action typ = List.mem_assoc typ actions in
      let get_value typ = List.assoc typ actions in

      is_action, get_value
    in

    if is_action "insert" then (
      let posn = get_action "insert" in
      let item = "New section - change this", "", "Write some content here." in
      model := action_insert !model posn item
    ) else if is_action "moveup" then (
      let posn = get_action "moveup" in
      model := action_moveup !model posn
    ) else if is_action "movedn" then (
      let posn = get_action "movedn" in
      model := action_movedn !model posn
    ) else if is_action "delete" then (
      let posn = get_action "delete" in
      model := action_delete !model posn
    );

    model_to_template !model template
  in

  (* Try to save the page.  Returns a boolean indicating if the
   * page was saved successfully.
   *)
  let try_save () =
    let model = build_internal_model () in
    let no_errors = [] = check_for_errors model in
    if no_errors then (
      (* No errors, so we can save the page ... *)

      (* Get the IP address of the user, if available. *)
      let logged_ip =
	try `String (Connection.remote_ip (Request.connection r))
	with Not_found -> `Null in

      let logged_user =
	match user with
	  | User (id, _, _) -> `Int id
	  | _ -> `Null in

      (* Get redirect. *)
      let redirect =
	if model.redirect = "" then `Null
        else `String model.redirect in

      let url, pageid =
	(* Creating a new page (id = 0)?  If so, we're just going to insert
	 * a new row, which is easy.
	 *)
	if model.id = 0 then (
	  (* Create the page title or URL. *)
	  let url, title =
	    match model.pt with
		Page url -> url, url
	      | Title title ->
		  match Wikilib.generate_url_of_title dbh hostid title with
		      Wikilib.GenURL_OK url -> url, title
		    | Wikilib.GenURL_Duplicate url ->
			error ~back_button:true ~title:"Page exists"
			  q ("While you were editing that page, it looks " ^
			     "like another user created the same page.");
			return ()
		    | _ ->
			assert false (* This should have been detected in
				      * begin_editing_new.
				      *) in

	  let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
                                        description, logged_ip, logged_user,
                                        redirect)
                                        values (?, ?, ?, ?, ?, ?, ?)" in
	  sth#execute [`Int hostid; `String url; `String title;
		       `String model.description; logged_ip; logged_user;
		       redirect];

	  let pageid = sth#serial "pages_id_seq" in

	  (* Create the page contents. *)
	  let sth = dbh#prepare_cached "insert into contents (pageid,
                                        ordering, sectionname, divname,
                                        content)
                                        values (?, ?, ?, ?, ?)" in
	  let ordering = ref 0 in	(* Creating new ordering. *)
	  List.iter (fun (sectionname, divname, content) ->
		       let divname =
			 if string_is_whitespace divname then `Null
			 else `String divname in
		       let sectionname =
			 if string_is_whitespace sectionname then `Null
			 else `String sectionname in
		       incr ordering; let ordering = !ordering in
		       sth#execute [`Int pageid; `Int ordering;
				    sectionname; divname;
				    `String content])
	    model.contents;

	  url, pageid
	)
	(* Otherwise it's an old page which we're updating. *)
	else (
	  (* Pull out fields from the database. *)
	  let sth = dbh#prepare_cached "select creation_date,
                                               coalesce (url, url_deleted),
                                               title, css
                                          from pages
                                         where hostid = ? and id = ?" in
	  sth#execute [`Int hostid; `Int model.id];

	  let creation_date, url, title, css =
	    match sth#fetch1 () with
		[ creation_date; `String url; `String title; css ] ->
		  creation_date, url, title, css
	      | _ -> assert false in

	  (* Has someone else edited this page in the meantime? *)
	  let sth = dbh#prepare_cached "select max(id) from pages
                                         where hostid = ? and url = ?" in
	  sth#execute [`Int hostid; `String url];

	  let max_id = sth#fetch1int () in
	  let edited = max_id <> model.id in

	  if edited then (
	    (* Edited by someone else ...  Get the other's changes. *)
	    let other_diff, _ =
	      get_diff dbh hostid url
		~old_version:model.id ~version:max_id () in

	    (* Synthesize our own changes. *)
	    let old_page = get_version_for_diff dbh model.id in
	    let new_page =
	      let css = match css with
		  `Null -> "" | `String css -> css
		| _ -> assert false in
	      page_for_diff css (List.map (fun (sectionname, _, content) ->
				sectionname, content) model.contents) in
	    let our_diff = diff_cmd old_page new_page in

	    (* Fill out the conflict template. *)
	    template_conflict#set "other_diff" other_diff;
	    template_conflict#set "our_diff" our_diff;
	    template_conflict#set "old_version" (string_of_int model.id);
	    template_conflict#set "new_version" (string_of_int max_id);
	    template_conflict#set "url" url;

	    q#template template_conflict;
	    return ()
	  );

	  (* Defer the pages_redirect_cn constraint because that would
	   * temporarily fail on the next UPDATE.
	   *)
	  let sth =
	    dbh#prepare_cached
	      "set constraints pages_redirect_cn, sitemenu_url_cn,
                   page_emails_url_cn, links_from_cn, recently_visited_url_cn
                   deferred" in
	  sth#execute [];

	  (* Mark the old page as deleted.  NB. There is a small race
	   * condition here because PostgreSQL doesn't do isolation
	   * properly.  If a user tries to visit this page between the
	   * delete and the creation of the new page, then they'll get
	   * a page not found error. (XXX)
	   *)
	  let sth = dbh#prepare_cached "update pages set url_deleted = url,
                                                         url = null
                                         where hostid = ? and id = ?" in
	  sth#execute [`Int hostid; `Int model.id];

	  (* Create the new page. *)
	  let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
                                        description, creation_date, logged_ip,
                                        logged_user, redirect, css)
                                        values (?, ?, ?, ?, ?, ?, ?, ?, ?)" in
	  sth#execute [`Int hostid; `String url; `String title;
		       `String model.description; creation_date; logged_ip;
		       logged_user; redirect; css];

	  (* New page ID <> old page ID model.id. *)
	  let pageid = sth#serial "pages_id_seq" in

	  (* Create the page contents. *)
	  let sth = dbh#prepare_cached "insert into contents (pageid,
                                        ordering, sectionname, divname,
                                        content)
                                        values (?, ?, ?, ?, ?)" in
	  let ordering = ref 0 in	(* Creating new ordering. *)
	  List.iter (fun (sectionname, divname, content) ->
		       let divname =
			 if string_is_whitespace divname then `Null
			 else `String divname in
		       let sectionname =
			 if string_is_whitespace sectionname then `Null
			 else `String sectionname in
		       incr ordering; let ordering = !ordering in
		       sth#execute [`Int pageid; `Int ordering;
				    sectionname; divname;
				    `String content])
	    model.contents;

	  (* General email notification of page edits.  Send an email to
	   * anyone in the page_emails table who has a confirmed address
	   * and who hasn't received an email already today.
	   *)
	  let sth = dbh#prepare_cached "select email, opt_out from page_emails
                                         where hostid = ? and url = ?
                                           and pending is null
                                           and last_sent < current_date" in
	  sth#execute [`Int hostid; `String url];

	  let addrs = sth#map (function [`String email; `String opt_out] ->
				 email, opt_out
				 | _ -> assert false) in

	  if addrs <> [] then (
	    (* Construct the email. *)
	    template_email#set "hostname" hostname;
	    template_email#set "page" url;

	    let subject =
	      "Site notice: " ^ hostname ^ "/" ^ url ^ " has been updated" in

	    (* Send each email individually (they all have different opt out
	     * links).
	     *)
	    List.iter (fun (to_addr, opt_out) ->
			 template_email#set "opt_out" opt_out;
			 let body = template_email#to_string in
			 Sendmail.send_mail ~subject
			   ~to_addr:[to_addr] ~body ())
	      addrs
	  );

	  (* Update the database to record when these emails were sent. *)
	  let sth = dbh#prepare_cached "update page_emails
                                           set last_sent = current_date
                                         where hostid = ? and url = ?
                                           and pending is null" in
	  sth#execute [`Int hostid; `String url];

	  url, pageid
	) in

      (* Keep the links table in synch. *)
      Cocanwiki_links.update_links_for_page dbh hostid url;

      (* Commit changes to the database. *)
      dbh#commit ();

      (* Email notification, if anyone is listed for this host. *)
      let subject = "Page " ^ url ^ " has been edited" in

      let body = fun () ->
	(* Prepare the diff between this version and the previous version. *)
	let diff, _ = get_diff dbh hostid url ~version:pageid () in
	"Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
	diff in

      email_notify ~body ~subject dbh hostid;

      (* Redirect back to the URL. *)
      q#redirect ("http://" ^ hostname ^ "/" ^ url);
      return ()
    );
  in

  let cancel id =
    let url =
      if id <> 0 then (
	let sth = dbh#prepare_cached "select url from pages
                                       where hostid = ? and id = ?" in
	sth#execute [`Int hostid; `Int id];
	sth#fetch1string ()
      ) else if q#param "pt_type" = "page" then
	q#param "pt_value"
      else
	(* Create a new page, but the user hits the cancel button.  Because
	 * we didn't save where they came from, we now have nowhere to
	 * go.  So we redirect to the home page. XXX
	 *)
	"" in

    q#redirect ("http://" ^ hostname ^ "/" ^ url);
    return ()
  in

  (* This codes decides where we are in the current editing cycle.
   *
   * Inputs:
   *   id - if set, then we are in the midst of editing a page.
   *   save - if set, then we want to save the page.
   *   cancel - if set, abandon changes and go back to viewing the page.
   *   action_* - one of the action buttons was set, eg. move up/down.
   *   page - the page URL opened newly for editing, or a template which
   *          doesn't yet exist.
   *   title - page doesn't yet exist; create it.
   *)
  let id =
    try Some (int_of_string (q#param "id")) with Not_found -> None in
  (match id with
     | None ->				(* Begin editing the page. *)
	 if q#param_exists "page" then (
	   let page = q#param "page" in
	   let page = if page = "" then "index" else page in
	   if page_exists page then
	     begin_editing page
	   else
	     begin_editing_new (Page page)
	 ) else (
	   let title = q#param "title" in
	   begin_editing_new (Title title)
	 )

     | Some id ->
	 if q#param_true "cancel" then
	   cancel id;
	 if q#param_true "save" then
	   try_save ();			(* might fail and fall through ... *)
	 continue_editing ()
  );

  q#template template

let () =
  register_script ~restrict:[CanEdit] run