(* 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.26 2005/03/31 14:24:04 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
open Cocanwiki_pages

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 | 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 =
    let model = load_page dbh hostid ~url:page () 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

    let model = match pt with
	Page url -> new_page pt
      | Title title -> new_page_with_title title 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 ... *)

      let url, pageid =
	try
	  save_page dbh hostid ~user ~r model
	with
	    SaveURLError ->
	      error ~back_button:true ~title:"Page exists"
	      q ("While you were editing that page, it looks " ^
		 "like another user created the same page.");
	      return ()

	  | SaveConflict (new_version, old_version, url, css) ->
	      (* Edited by someone else ...  Get the other's changes. *)
	      let other_diff, _ =
		get_diff dbh hostid url ~old_version ~version:new_version () in

	      (* Synthesize our own changes. *)
	      let old_page = get_version_for_diff dbh old_version in
	      let new_page =
		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 old_version);
	      template_conflict#set "new_version" (string_of_int new_version);
	      template_conflict#set "url" url;

	      q#template template_conflict;
	      return () in

      (* 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];

      (* 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 ~user 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 coalesce (url, url_deleted)
                                        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