scripts/edit.ml

   1 (* COCANWIKI - a wiki written in Objective CAML.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: edit.ml,v 1.28 2006/03/27 18:09:46 rich Exp $
   5  *
   6  * This program is free software; you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation; either version 2 of the License, or
   9  * (at your option) any later version.
  10  *
  11  * This program is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  * GNU General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU General Public License
  17  * along with this program; see the file COPYING.  If not, write to
  18  * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19  * Boston, MA 02111-1307, USA.
  20  *)
  21
  22 open Apache
  23 open Registry
  24 open Cgi
  25 open Printf
  26
  27 open ExtString
  28
  29 open Cocanwiki
  30 open Cocanwiki_template
  31 open Cocanwiki_ok
  32 open Cocanwiki_emailnotify
  33 open Cocanwiki_diff
  34 open Cocanwiki_strings
  35 open Cocanwiki_pages
  36
  37 let run r (q : cgi) dbh hostid {hostname = hostname} user =
  38   let template = get_template dbh hostid "edit.html" in
  39   let template_conflict = get_template dbh hostid "edit_conflict.html" in
  40   let template_email = get_template dbh hostid "edit_page_email.txt" in
  41
  42   (* Workaround bugs in IE, specifically lack of support for <button>
  43    * elements.
  44    *)
  45   let msie =
  46     try
  47       let ua = Table.get (Request.headers_in r) "User-Agent" in
  48       ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
  49       true
  50     with
  51         Not_found | Invalid_string -> false in
  52   template#conditional "msie" msie;
  53
  54   (* Build the internal model from the parameters passed to the script. *)
  55   let build_internal_model () =
  56     let id = Int32.of_string (q#param "id") in
  57     let description = q#param "description" in
  58     let redirect = q#param "redirect" in
  59     let redirect =
  60       if string_is_whitespace redirect then
  61         None else Some redirect in
  62     let pt = match q#param "pt_type" with
  63       | "page" -> Page (q#param "pt_value")
  64       | "title" -> Title (q#param "pt_value")
  65       | _ -> failwith "unknown value for pt_type parameter" in
  66
  67     let contents = ref [] in
  68     let i = ref 1 in
  69     while q#param_exists ("content_" ^ string_of_int !i) do
  70       let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
  71       let sectionname =
  72         if string_is_whitespace sectionname then None else Some sectionname in
  73       let content = q#param ("content_" ^ string_of_int !i) in
  74       let divname = q#param ("divname_" ^ string_of_int !i) in
  75       let divname =
  76         if string_is_whitespace divname then None else Some divname in
  77       contents := (sectionname, divname, content) :: !contents;
  78       incr i
  79     done;
  80     let contents = List.rev !contents in
  81
  82     { id = id;
  83       pt = pt;
  84       description = description;
  85       redirect = redirect;
  86       contents_ = contents; }
  87   in
  88
  89   (* Check for errors in the model. *)
  90   let check_for_errors model =
  91     let errors = ref [] in
  92     let add_error msg = errors := msg :: !errors in
  93     let get_errors () = List.rev !errors in
  94
  95     (match model.redirect with
  96      | None ->
  97          (* Empty page? *)
  98          if model.contents_ = [] then
  99            add_error ("This page is empty.  Use 'Insert new section here' " ^
 100                         "to write something!");
 101
 102          (* Description field? *)
 103          if model.description = "" then
 104            add_error ("The description field is very important!  " ^
 105                         "This field is " ^
 106                         "used by search engines and directories to describe " ^
 107                         "what's on this page.");
 108
 109      | Some redirect ->
 110          (* Redirect points to a real page? *)
 111          let rows =
 112            let model_id = model.id in
 113            PGSQL(dbh)
 114            "select 1 from pages
 115              where hostid = $hostid and url is not null
 116                and url = $redirect and id <> $model_id
 117                and redirect is null" in
 118
 119          let ok = rows = [Some 1l] in
 120          if not ok then
 121            add_error ("Redirect must point to an ordinary page " ^
 122                         "(ie. not to a page which is itself a redirect).")
 123     );
 124
 125     (* All sections after the first one have sectionnames?  The first
 126      * section ONLY is allowed to have an empty title.
 127      *)
 128     if model.contents_ <> [] then
 129       List.iter (function (None, _, _) ->
 130                    add_error
 131                      ("Every section except the first must have a title.");
 132                  | _ -> ())
 133         (List.tl model.contents_);
 134
 135     get_errors ()
 136   in
 137
 138   (* Various "actions" that can be performed on the model. *)
 139   let action_insert model posn item =
 140     (* posn = 0 means insert before the first element of the current list. *)
 141     let rec loop =
 142       function
 143           0, xs -> item :: xs
 144         | _, [] -> [ item ]
 145         | n, x :: xs -> x :: (loop (n-1, xs))
 146     in
 147     let contents = loop (posn, model.contents_) in
 148     { model with contents_ = contents }
 149   in
 150   let action_moveup model posn =
 151     (* posn = 1 means move up the first element, ie. do nothing
 152      * posn = 2 means move up the second element to the first position
 153      * etc.
 154      *)
 155     let rec loop =
 156       function
 157           0, xs
 158         | 1, xs -> xs
 159         | _, [] -> []
 160         | 2, x :: y :: xs -> y :: x :: xs
 161         | n, x :: xs -> x :: (loop (n-1, xs))
 162     in
 163     let contents = loop (posn, model.contents_) in
 164     { model with contents_ = contents }
 165   in
 166   let action_movedn model posn =
 167     (* posn = 1 means move down the first element to the second position
 168      * etc.
 169      *)
 170     let rec loop =
 171       function
 172           0, xs -> xs
 173         | _, [] -> []
 174         | 1, x :: y :: xs -> y :: x :: xs
 175         | n, x :: xs -> x :: (loop (n-1, xs))
 176     in
 177     let contents = loop (posn, model.contents_) in
 178     { model with contents_ = contents }
 179   in
 180   let action_delete model posn =
 181     (* posn = 1 means delete the first element *)
 182     let rec loop =
 183       function
 184           0, xs -> xs
 185         | _, [] -> []
 186         | 1, x :: xs -> xs
 187         | n, x :: xs -> x :: (loop (n-1, xs))
 188     in
 189     let contents = loop (posn, model.contents_) in
 190     { model with contents_ = contents }
 191   in
 192
 193   (* Convert model to template. *)
 194   let model_to_template model template =
 195     template#set "id" (Int32.to_string model.id);
 196     template#set "description" model.description;
 197
 198     (match model.pt with
 199          Page page ->
 200            template#set "pt_type" "page";
 201            template#set "pt_value" page
 202        | Title title ->
 203            template#set "pt_type" "title";
 204            template#set "pt_value" title);
 205
 206     (* Redirects table. *)
 207     let rows =
 208       let model_id = model.id in
 209       PGSQL(dbh)
 210       "select url, title from pages
 211         where url is not null
 212           and redirect is null
 213           and hostid = $hostid and id <> $model_id
 214         order by 2" in
 215     let table = List.map (
 216       fun (url, title) ->
 217         let url = Option.get url in
 218         let selected = model.redirect = Some url in
 219         [ "url", Template.VarString url;
 220           "title", Template.VarString title;
 221           "selected", Template.VarConditional selected ]
 222     ) rows in
 223     template#table "redirects" table;
 224
 225     if model.id <> 0l then (
 226       (* Need to go to the database to get the title of the page ... *)
 227       let rows =
 228         let model_id = model.id in
 229         PGSQL(dbh)
 230           "select title from pages
 231             where hostid = $hostid and id = $model_id" in
 232       let title = List.hd rows in
 233       template#set "title" title;
 234     ) else (
 235       match model.pt with
 236       | Page page -> template#set "title" page
 237       | Title title -> template#set "title" title
 238     );
 239
 240     let ordering = ref 0 in
 241     let table =
 242       List.map
 243         (fun (sectionname, divname, content) ->
 244            incr ordering; let ordering = Int32.of_int !ordering in
 245            let sectionname = match sectionname with None -> "" | Some s -> s in
 246            let divname = match divname with None -> "" | Some s -> s in
 247            [ "ordering", Template.VarString (Int32.to_string ordering);
 248              "sectionname", Template.VarString sectionname;
 249              "divname", Template.VarString divname;
 250              "content", Template.VarString content ]) model.contents_ in
 251     template#table "contents" table;
 252
 253     (* Check for errors and put those into the template. *)
 254     let errors = check_for_errors model in
 255     let errors = List.map (fun msg ->
 256                              [ "error", Template.VarString msg ]) errors in
 257     template#table "errors" errors;
 258     template#conditional "has_errors" (errors <> [])
 259   in
 260
 261   (* Check if a URL exists in the database. *)
 262   let page_exists page =
 263     let rows = PGSQL(dbh)
 264       "select 1 from pages where hostid = $hostid and url = $page" in
 265     rows = [ Some 1l ]
 266   in
 267
 268   (* Begin editing a page, pulling the page out of the database and building
 269    * a model from it.
 270    *)
 271   let begin_editing page =
 272     let model = load_page dbh hostid ~url:page () in
 273     model_to_template model template
 274   in
 275
 276   (* Begin editing with a blank page, typically a template. *)
 277   let begin_editing_new pt =
 278     let url, title =
 279       match pt with
 280           Page url -> url, url
 281         | Title title ->
 282             match Wikilib.generate_url_of_title dbh hostid title with
 283                 Wikilib.GenURL_OK url -> url, title
 284               | Wikilib.GenURL_Duplicate url ->
 285                   q#redirect ("http://" ^ hostname ^ "/" ^ url);
 286                   return ()
 287               | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
 288                   error ~back_button:true ~title:"Bad page name"
 289                     dbh hostid q
 290                     "The page name supplied is too short or invalid.";
 291                   return () in
 292
 293     let model = match pt with
 294         Page url -> new_page pt
 295       | Title title -> new_page_with_title title in
 296
 297     model_to_template model template
 298   in
 299
 300   let continue_editing () =
 301     let model = ref (build_internal_model ()) in
 302
 303     (* An "action" parameter? *)
 304     let is_action, get_action =
 305       let actions = q#params in
 306       (* Don't actually care about the value fields ... *)
 307       let actions = List.map (fun (str, _) -> str) actions in
 308       (* Some of our actions are imagemaps, so parameters like name.x, name.y
 309        * need to be changed to name and have resulting duplicates removed.
 310        *)
 311       let actions =
 312         List.filter (fun str ->
 313                        String.length str > 7 &&
 314                        String.sub str 0 7 = "action_" &&
 315                        not (String.ends_with str ".y")) actions in
 316       let actions =
 317         List.map (fun str ->
 318                     if String.ends_with str ".x" then (
 319                       let str = String.sub str 0 (String.length str - 2) in
 320                       str
 321                     )
 322                     else str) actions in
 323       let actions =
 324         List.map (fun str ->
 325                     let action_type = String.sub str 7 6 in
 326                     let action_value =
 327                       String.sub str 14 (String.length str - 14) in
 328                     let action_value = int_of_string action_value in
 329                     action_type, action_value) actions in
 330
 331       let is_action typ = List.mem_assoc typ actions in
 332       let get_value typ = List.assoc typ actions in
 333
 334       is_action, get_value
 335     in
 336
 337     if is_action "insert" then (
 338       let posn = get_action "insert" in
 339       let item =
 340         Some "The title of this section", None, "Write something here." in
 341       model := action_insert !model posn item
 342     ) else if is_action "moveup" then (
 343       let posn = get_action "moveup" in
 344       model := action_moveup !model posn
 345     ) else if is_action "movedn" then (
 346       let posn = get_action "movedn" in
 347       model := action_movedn !model posn
 348     ) else if is_action "delete" then (
 349       let posn = get_action "delete" in
 350       model := action_delete !model posn
 351     );
 352
 353     model_to_template !model template
 354   in
 355
 356   (* Try to save the page.  Returns a boolean indicating if the
 357    * page was saved successfully.
 358    *)
 359   let try_save () =
 360     let model = build_internal_model () in
 361     let no_errors = [] = check_for_errors model in
 362     if no_errors then (
 363       (* No errors, so we can save the page ... *)
 364
 365       let url, pageid =
 366         try
 367           save_page dbh hostid ~user ~r model
 368         with
 369             SaveURLError ->
 370               error ~back_button:true ~title:"Page exists"
 371                 dbh hostid q ("While you were editing that page, it looks " ^
 372                               "like another user created the same page.");
 373               return ()
 374
 375           | SaveConflict (new_version, old_version, url, css) ->
 376               (* Edited by someone else ...  Get the other's changes. *)
 377               let other_diff, _ =
 378                 get_diff dbh hostid url ~old_version ~version:new_version () in
 379
 380               (* Synthesize our own changes. *)
 381               let old_page = get_version_for_diff dbh old_version in
 382               let new_page =
 383                 page_for_diff css (List.map (
 384                                      fun (sectionname, _, content) ->
 385                                        let sectionname = match sectionname with
 386                                          | None -> ""
 387                                          | Some s -> s in
 388                                        sectionname, content
 389                                    ) model.contents_) in
 390               let our_diff = diff_cmd old_page new_page in
 391
 392               (* Fill out the conflict template. *)
 393               template_conflict#set "other_diff" other_diff;
 394               template_conflict#set "our_diff" our_diff;
 395               template_conflict#set "old_version" (Int32.to_string old_version);
 396               template_conflict#set "new_version" (Int32.to_string new_version);
 397               template_conflict#set "url" url;
 398
 399               q#template template_conflict;
 400               return () in
 401
 402       (* General email notification of page edits.  Send an email to
 403        * anyone in the page_emails table who has a confirmed address
 404        * and who hasn't received an email already today.
 405        *)
 406       let rows = PGSQL(dbh)
 407         "select email, opt_out from page_emails
 408           where hostid = $hostid and url = $url
 409             and pending is null
 410             and last_sent < current_date" in
 411       let addrs = List.map (
 412         fun (email, opt_out) ->
 413           email, opt_out
 414       ) rows in
 415
 416       if addrs <> [] then (
 417         (* Construct the email. *)
 418         template_email#set "hostname" hostname;
 419         template_email#set "page" url;
 420
 421         let subject =
 422           "Site notice: " ^ hostname ^ "/" ^ url ^ " has been updated" in
 423
 424         (* Send each email individually (they all have different opt out
 425          * links).
 426          *)
 427         List.iter (fun (to_addr, opt_out) ->
 428                      template_email#set "opt_out" opt_out;
 429                      let body = template_email#to_string in
 430                      Sendmail.send_mail ~subject
 431                        ~to_addr:[to_addr] body)
 432           addrs
 433       );
 434
 435       (* Update the database to record when these emails were sent. *)
 436       PGSQL(dbh)
 437         "update page_emails
 438             set last_sent = current_date
 439           where hostid = $hostid and url = $url
 440             and pending is null";
 441
 442       (* Commit changes to the database. *)
 443       PGOCaml.commit dbh;
 444
 445       (* Email notification, if anyone is listed for this host. *)
 446       let subject = "Page " ^ url ^ " has been edited" in
 447
 448       let body = fun () ->
 449         (* Prepare the diff between this version and the previous version. *)
 450         let diff, _ = get_diff dbh hostid url ~version:pageid () in
 451         "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
 452         diff in
 453
 454       email_notify ~body ~subject ~user dbh hostid;
 455
 456       (* Redirect back to the URL. *)
 457       q#redirect ("http://" ^ hostname ^ "/" ^ url);
 458       return ()
 459     );
 460   in
 461
 462   let cancel id =
 463     let url =
 464       if id <> 0l then (
 465         let rows = PGSQL(dbh)
 466           "select coalesce (url, url_deleted)
 467              from pages
 468             where hostid = $hostid and id = $id" in
 469         Option.get (List.hd rows)
 470       ) else if q#param "pt_type" = "page" then
 471         q#param "pt_value"
 472       else
 473         (* Create a new page, but the user hits the cancel button.  Because
 474          * we didn't save where they came from, we now have nowhere to
 475          * go.  So we redirect to the home page. XXX
 476          *)
 477         "" in
 478
 479     q#redirect ("http://" ^ hostname ^ "/" ^ url);
 480     return ()
 481   in
 482
 483   (* This code decides where we are in the current editing cycle.
 484    *
 485    * Inputs:
 486    *   id - if set, then we are in the midst of editing a page.
 487    *   save - if set, then we want to save the page.
 488    *   cancel - if set, abandon changes and go back to viewing the page.
 489    *   action_* - one of the action buttons was set, eg. move up/down.
 490    *   page - the page URL opened newly for editing, or a template which
 491    *          doesn't yet exist.
 492    *   title - page doesn't yet exist; create it.
 493    *)
 494   let id =
 495     try Some (Int32.of_string (q#param "id")) with Not_found -> None in
 496   (match id with
 497      | None ->                          (* Begin editing the page. *)
 498          if q#param_exists "page" then (
 499            let page = q#param "page" in
 500            let page = if page = "" then "index" else page in
 501            if page_exists page then
 502              begin_editing page
 503            else
 504              begin_editing_new (Page page)
 505          ) else (
 506            let title = q#param "title" in
 507            begin_editing_new (Title title)
 508          )
 509
 510      | Some id ->
 511          if q#param_true "cancel" then
 512            cancel id;
 513          if q#param_true "save" then
 514            try_save ();                 (* might fail and fall through ... *)
 515          continue_editing ()
 516   );
 517
 518   q#template template
 519
 520 let () =
 521   register_script ~restrict:[CanEdit] run