(* COCANWIKI scripts.
 * Written by Richard W.M. Jones <rich@merjis.com>.
 * Copyright (C) 2004 Merjis Ltd.
 * $Id: edit.ml,v 1.3 2004/09/07 14:58:34 rich Exp $
 *)

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

let template = get_template "edit.html"
let template_conflict = get_template "edit_conflict.html"

(* We keep an "internal model" of the page - see build_internal_model ()
 * below.
 *)
type model_t = {
  id : int;				(* Original page ID. *)
  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, _) _ =
  (* 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 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;
      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 have sectionnames? *)
    List.iter (function (sectionnames, _, _)
		   when string_is_whitespace sectionnames ->
		     add_error ("Every section must have a title.");
		 | _ -> ())
      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;

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

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

    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

  (* 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 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;
		  description = description;
		  redirect = 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 ... *)

      (* 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;
	raise CgiExit
      );

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

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

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

      (* Create the new page. *)
      let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
                                      description, creation_date, logged_ip,
                                      redirect, css)
                                    values (?, ?, ?, ?, ?, ?, ?, ?)" in
      sth#execute [`Int hostid; `String url; `String title;
		   `String model.description; creation_date; logged_ip;
		   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
		   incr ordering; let ordering = !ordering in
		   sth#execute [`Int pageid; `Int ordering;
				`String sectionname; divname;
				`String content])
	model.contents;

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

      let buttons = [ ok_button ("/" ^ url) ] in
      ok ~title:"Saved" ~buttons
        q "The page was saved."
    );

    no_errors
  in

  let cancel id =
    let sth = dbh#prepare_cached "select url from pages
                                   where hostid = ? and id = ?" in
    sth#execute [`Int hostid; `Int id];
    let url = sth#fetch1string () in

    q#redirect ("http://" ^ hostname ^ "/" ^ url)
  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.
   *)
  (try
     let id = int_of_string (q#param "id") in
     if q#param_true "cancel" then (
       cancel id;
       raise CgiExit
     );
     if q#param_true "save" then (
       let ok = try_save () in
       if ok then raise CgiExit		(* ... else fall through *)
     );
     continue_editing ()		(* Processes the action, if any. *)
   with
       Not_found ->
	 let page = q#param "page" in
	 let page = if page = "" then "index" else page in
	 begin_editing page);

  q#template template

let () =
  register_script run