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.12 2004/09/24 15:53:57 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
  36 (* We keep an "internal model" of the page - see build_internal_model ()
  37  * below.
  38  *)
  39 type model_t = {
  40   id : int;                             (* Original page ID. *)
  41   description : string;                 (* Description. *)
  42   redirect : string;                    (* Redirect to ("" = none). *)
  43   contents : (string * string * string) list;
  44                                         (* (sectionname, divname, content)
  45                                          * for each section. *)
  46 }
  47
  48 let run r (q : cgi) (dbh : Dbi.connection) hostid {hostname = hostname} user =
  49   let template = get_template dbh hostid "edit.html" in
  50   let template_conflict = get_template dbh hostid "edit_conflict.html" in
  51   let template_email = get_template dbh hostid "edit_page_email.txt" in
  52
  53   (* Workaround bugs in IE, specifically lack of support for <button>
  54    * elements.
  55    *)
  56   let msie =
  57     try
  58       let ua = Table.get (Request.headers_in r) "User-Agent" in
  59       ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
  60       true
  61     with
  62         Not_found | String.Invalid_string -> false in
  63   template#conditional "msie" msie;
  64
  65   (* Build the internal model from the parameters passed to the script. *)
  66   let build_internal_model () =
  67     let id = int_of_string (q#param "id") in
  68     let description = q#param "description" in
  69     let redirect = q#param "redirect" in
  70
  71     let contents = ref [] in
  72     let i = ref 1 in
  73     while q#param_exists ("content_" ^ string_of_int !i) do
  74       let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
  75       let content = q#param ("content_" ^ string_of_int !i) in
  76       let divname = q#param ("divname_" ^ string_of_int !i) in
  77       contents := (sectionname, divname, content) :: !contents;
  78       incr i
  79     done;
  80     let contents = List.rev !contents in
  81
  82     { id = id;
  83       description = description;
  84       redirect = redirect;
  85       contents = contents; }
  86   in
  87
  88   (* Check for errors in the model. *)
  89   let check_for_errors model =
  90     let errors = ref [] in
  91     let add_error msg = errors := msg :: !errors in
  92     let get_errors () = List.rev !errors in
  93
  94     if model.redirect = "" then (
  95       (* Empty page? *)
  96       if model.contents = [] then
  97         add_error ("This page is empty.  Use 'Insert new section here' " ^
  98                    "to write something!");
  99
 100       (* Description field? *)
 101       if model.description = "" then
 102         add_error ("The description field is very important!  This field is " ^
 103                    "used by search engines and directories to describe " ^
 104                    "what's on this page.");
 105     )
 106     else (* it's a redirect *) (
 107       (* Redirect points to a real page? *)
 108       let sth = dbh#prepare_cached "select 1 from pages
 109                                      where hostid = ?
 110                                        and url is not null
 111                                        and url = ?
 112                                        and id <> ?
 113                                        and redirect is null" in
 114       sth#execute [`Int hostid; `String model.redirect; `Int model.id];
 115
 116       let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
 117       if not ok then
 118         add_error ("Redirect must point to an ordinary page " ^
 119                    "(ie. not to a page which is itself a redirect).")
 120     );
 121
 122     (* All sections after the first one have sectionnames?  The first
 123      * section ONLY is allowed to have an empty title.
 124      *)
 125     if model.contents <> [] then
 126       List.iter (function (sectionnames, _, _)
 127                      when string_is_whitespace sectionnames ->
 128                        add_error
 129                        ("Every section except the first must have a title.");
 130                    | _ -> ())
 131         (List.tl model.contents);
 132
 133     get_errors ()
 134   in
 135
 136   (* Various "actions" that can be performed on the model. *)
 137   let action_insert model posn item =
 138     (* posn = 0 means insert before the first element of the current list. *)
 139     let rec loop =
 140       function
 141           0, xs -> item :: xs
 142         | _, [] -> [ item ]
 143         | n, x :: xs -> x :: (loop (n-1, xs))
 144     in
 145     let contents = loop (posn, model.contents) in
 146     { model with contents = contents }
 147   in
 148   let action_moveup model posn =
 149     (* posn = 1 means move up the first element, ie. do nothing
 150      * posn = 2 means move up the second element to the first position
 151      * etc.
 152      *)
 153     let rec loop =
 154       function
 155           0, xs
 156         | 1, xs -> xs
 157         | _, [] -> []
 158         | 2, x :: y :: xs -> y :: x :: xs
 159         | n, x :: xs -> x :: (loop (n-1, xs))
 160     in
 161     let contents = loop (posn, model.contents) in
 162     { model with contents = contents }
 163   in
 164   let action_movedn model posn =
 165     (* posn = 1 means move down the first element to the second position
 166      * etc.
 167      *)
 168     let rec loop =
 169       function
 170           0, xs -> xs
 171         | _, [] -> []
 172         | 1, x :: y :: xs -> y :: x :: xs
 173         | n, x :: xs -> x :: (loop (n-1, xs))
 174     in
 175     let contents = loop (posn, model.contents) in
 176     { model with contents = contents }
 177   in
 178   let action_delete model posn =
 179     (* posn = 1 means delete the first element *)
 180     let rec loop =
 181       function
 182           0, xs -> xs
 183         | _, [] -> []
 184         | 1, x :: xs -> xs
 185         | n, x :: xs -> x :: (loop (n-1, xs))
 186     in
 187     let contents = loop (posn, model.contents) in
 188     { model with contents = contents }
 189   in
 190
 191   (* Convert model to template. *)
 192   let model_to_template model template =
 193     template#set "id" (string_of_int model.id);
 194     template#set "description" model.description;
 195
 196     (* Redirects table. *)
 197     let sth = dbh#prepare_cached "select url, title from pages
 198                                    where url is not null
 199                                      and redirect is null
 200                                      and hostid = ? and id <> ?
 201                                    order by 2" in
 202     sth#execute [`Int hostid; `Int model.id];
 203     let table = sth#map (function [`String url; `String title] ->
 204                            let selected = model.redirect = url in
 205                            [ "url", Template.VarString url;
 206                              "title", Template.VarString title;
 207                              "selected", Template.VarConditional selected ]
 208                            | _ -> assert false) in
 209     template#table "redirects" table;
 210
 211     (* Need to go to the database to get the title of the page ... *)
 212     let sth = dbh#prepare_cached "select title from pages
 213                                    where hostid = ? and id = ?" in
 214     sth#execute [`Int hostid; `Int model.id];
 215     let title = sth#fetch1string () in
 216     template#set "title" title;
 217
 218     let ordering = ref 0 in
 219     let table =
 220       List.map
 221         (fun (sectionname, divname, content) ->
 222            incr ordering; let ordering = !ordering in
 223            [ "ordering", Template.VarString (string_of_int ordering);
 224              "sectionname", Template.VarString sectionname;
 225              "divname", Template.VarString divname;
 226              "content", Template.VarString content ]) model.contents in
 227     template#table "contents" table;
 228
 229     (* Check for errors and put those into the template. *)
 230     let errors = check_for_errors model in
 231     let errors = List.map (fun msg ->
 232                              [ "error", Template.VarString msg ]) errors in
 233     template#table "errors" errors;
 234     template#conditional "has_errors" (errors <> [])
 235   in
 236
 237   (* Begin editing a page, pulling the page out of the database and building
 238    * a model from it.
 239    *)
 240   let begin_editing page =
 241     (* Pull out the page itself from the database. *)
 242     let sth = dbh#prepare_cached "select id, title, description,
 243                                          coalesce (redirect, '')
 244                                     from pages
 245                                    where hostid = ? and url = ?" in
 246     sth#execute [`Int hostid; `String page];
 247
 248     let pageid, title, description, redirect =
 249       match sth#fetch1 () with
 250           [`Int pageid; `String title; `String description; `String redirect]->
 251             pageid, title, description, redirect
 252         | _ -> assert false in
 253
 254     (* Get the sections. *)
 255     let sth = dbh#prepare_cached "select coalesce (sectionname, ''),
 256                                          content,
 257                                          coalesce (divname, '')
 258                                     from contents
 259                                    where pageid = ?
 260                                    order by ordering" in
 261     sth#execute [`Int pageid];
 262
 263     let contents =
 264       sth#map (function
 265                  | [`String sectionname; `String content; `String divname] ->
 266                      sectionname, divname, content
 267                  | _ -> assert false) in
 268
 269     let model = { id = pageid;
 270                   description = description;
 271                   redirect = redirect;
 272                   contents = contents; } in
 273
 274     model_to_template model template
 275   in
 276
 277   let continue_editing () =
 278     let model = ref (build_internal_model ()) in
 279
 280     (* An "action" parameter? *)
 281     let is_action, get_action =
 282       let actions = q#params in
 283       (* Don't actually care about the value fields ... *)
 284       let actions = List.map (fun (str, _) -> str) actions in
 285       (* Some of our actions are imagemaps, so parameters like name.x, name.y
 286        * need to be changed to name and have resulting duplicates removed.
 287        *)
 288       let actions =
 289         List.filter (fun str ->
 290                        String.length str > 7 &&
 291                        String.sub str 0 7 = "action_" &&
 292                        not (String.ends_with str ".y")) actions in
 293       let actions =
 294         List.map (fun str ->
 295                     if String.ends_with str ".x" then (
 296                       let str = String.sub str 0 (String.length str - 2) in
 297                       str
 298                     )
 299                     else str) actions in
 300       let actions =
 301         List.map (fun str ->
 302                     let action_type = String.sub str 7 6 in
 303                     let action_value =
 304                       String.sub str 14 (String.length str - 14) in
 305                     let action_value = int_of_string action_value in
 306                     action_type, action_value) actions in
 307
 308       let is_action typ = List.mem_assoc typ actions in
 309       let get_value typ = List.assoc typ actions in
 310
 311       is_action, get_value
 312     in
 313
 314     if is_action "insert" then (
 315       let posn = get_action "insert" in
 316       let item = "New section - change this", "", "Write some content here." in
 317       model := action_insert !model posn item
 318     ) else if is_action "moveup" then (
 319       let posn = get_action "moveup" in
 320       model := action_moveup !model posn
 321     ) else if is_action "movedn" then (
 322       let posn = get_action "movedn" in
 323       model := action_movedn !model posn
 324     ) else if is_action "delete" then (
 325       let posn = get_action "delete" in
 326       model := action_delete !model posn
 327     );
 328
 329     model_to_template !model template
 330   in
 331
 332   (* Try to save the page.  Returns a boolean indicating if the
 333    * page was saved successfully.
 334    *)
 335   let try_save () =
 336     let model = build_internal_model () in
 337     let no_errors = [] = check_for_errors model in
 338     if no_errors then (
 339       (* No errors, so we can save the page ... *)
 340
 341       (* Pull out fields from the database. *)
 342       let sth = dbh#prepare_cached "select creation_date,
 343                                            coalesce (url, url_deleted),
 344                                            title, css
 345                                       from pages
 346                                      where hostid = ? and id = ?" in
 347       sth#execute [`Int hostid; `Int model.id];
 348
 349       let creation_date, url, title, css =
 350         match sth#fetch1 () with
 351             [ creation_date; `String url; `String title; css ] ->
 352               creation_date, url, title, css
 353           | _ -> assert false in
 354
 355       (* Has someone else edited this page in the meantime? *)
 356       let sth = dbh#prepare_cached "select max(id) from pages
 357                                      where hostid = ? and url = ?" in
 358       sth#execute [`Int hostid; `String url];
 359
 360       let max_id = sth#fetch1int () in
 361       let edited = max_id <> model.id in
 362
 363       if edited then (
 364         (* Edited by someone else ...  Get the other's changes. *)
 365         let other_diff, _ =
 366           get_diff dbh hostid url ~old_version:model.id ~version:max_id () in
 367
 368         (* Synthesize our own changes. *)
 369         let old_page = get_version_for_diff dbh model.id in
 370         let new_page =
 371           let css = match css with
 372               `Null -> "" | `String css -> css
 373             | _ -> assert false in
 374           page_for_diff css (List.map (fun (sectionname, _, content) ->
 375                                sectionname, content) model.contents) in
 376         let our_diff = diff_cmd old_page new_page in
 377
 378         (* Fill out the conflict template. *)
 379         template_conflict#set "other_diff" other_diff;
 380         template_conflict#set "our_diff" our_diff;
 381         template_conflict#set "old_version" (string_of_int model.id);
 382         template_conflict#set "new_version" (string_of_int max_id);
 383         template_conflict#set "url" url;
 384
 385         q#template template_conflict;
 386         return ()
 387       );
 388
 389       (* Defer the pages_redirect_cn constraint because that would
 390        * temporarily fail on the next UPDATE.
 391        *)
 392       let sth =
 393         dbh#prepare_cached
 394           "set constraints pages_redirect_cn, sitemenu_url_cn,
 395                page_emails_url_cn deferred" in
 396       sth#execute [];
 397
 398       (* Mark the old page as deleted.  NB. There is a small race
 399        * condition here because PostgreSQL doesn't do isolation
 400        * properly.  If a user tries to visit this page between the
 401        * delete and the creation of the new page, then they'll get
 402        * a page not found error. (XXX)
 403        *)
 404       let sth = dbh#prepare_cached "update pages set url_deleted = url,
 405                                                      url = null
 406                                      where hostid = ? and id = ?" in
 407       sth#execute [`Int hostid; `Int model.id];
 408
 409       (* Get the IP address of the user, if available. *)
 410       let logged_ip =
 411         try `String (Connection.remote_ip (Request.connection r))
 412         with Not_found -> `Null in
 413
 414       let logged_user =
 415         match user with
 416           | User (id, _, _) -> `Int id
 417           | _ -> `Null in
 418
 419       (* Get redirect. *)
 420       let redirect = if model.redirect = "" then `Null
 421                      else `String model.redirect in
 422
 423       (* Create the new page. *)
 424       let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
 425                                       description, creation_date, logged_ip,
 426                                       logged_user, redirect, css)
 427                                     values (?, ?, ?, ?, ?, ?, ?, ?, ?)" in
 428       sth#execute [`Int hostid; `String url; `String title;
 429                    `String model.description; creation_date; logged_ip;
 430                    logged_user; redirect; css];
 431
 432       (* New page ID <> old page ID model.id. *)
 433       let pageid = sth#serial "pages_id_seq" in
 434
 435       (* Create the page contents. *)
 436       let sth = dbh#prepare_cached "insert into contents (pageid,
 437                                       ordering, sectionname, divname, content)
 438                                     values (?, ?, ?, ?, ?)" in
 439       let ordering = ref 0 in           (* Creating new ordering. *)
 440       List.iter (fun (sectionname, divname, content) ->
 441                    let divname =
 442                      if string_is_whitespace divname then `Null
 443                      else `String divname in
 444                    let sectionname =
 445                      if string_is_whitespace sectionname then `Null
 446                      else `String sectionname in
 447                    incr ordering; let ordering = !ordering in
 448                    sth#execute [`Int pageid; `Int ordering;
 449                                 sectionname; divname;
 450                                 `String content])
 451         model.contents;
 452
 453       (* Commit changes to the database. *)
 454       dbh#commit ();
 455
 456       (* Email notification, if anyone is listed for this host. *)
 457       let subject = "Page " ^ url ^ " has been edited" in
 458
 459       let body = fun () ->
 460         (* Prepare the diff between this version and the previous version. *)
 461         let diff, _ = get_diff dbh hostid url ~version:pageid () in
 462         "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
 463         diff in
 464
 465       email_notify ~body ~subject dbh hostid;
 466
 467       (* General email notification of page edits.  Send an email to
 468        * anyone in the page_emails table who has a confirmed address
 469        * and who hasn't received an email already today.
 470        *)
 471       let sth = dbh#prepare_cached "select email, opt_out from page_emails
 472                                      where hostid = ? and url = ?
 473                                        and pending is null
 474                                        and last_sent < current_date" in
 475       sth#execute [`Int hostid; `String url];
 476
 477       let addrs = sth#map (function [`String email; `String opt_out] ->
 478                              email, opt_out
 479                              | _ -> assert false) in
 480
 481       if addrs <> [] then (
 482         (* Construct the email. *)
 483         template_email#set "hostname" hostname;
 484         template_email#set "page" url;
 485
 486         let subject =
 487           "Site notice: " ^ hostname ^ "/" ^ url ^ " has been updated" in
 488
 489         (* Send each email individually (they all have different opt out
 490          * links).
 491          *)
 492         List.iter (fun (to_addr, opt_out) ->
 493                      template_email#set "opt_out" opt_out;
 494                      let body = template_email#to_string in
 495                      Sendmail.send_mail ~subject ~to_addr:[to_addr] ~body ())
 496           addrs
 497       );
 498
 499       (* Update the database to record when these emails were sent. *)
 500       let sth = dbh#prepare_cached "update page_emails
 501                                        set last_sent = current_date
 502                                      where hostid = ? and url = ?
 503                                        and pending is null" in
 504       sth#execute [`Int hostid; `String url];
 505
 506       dbh#commit ();
 507
 508       let buttons = [ ok_button ("/" ^ url) ] in
 509       ok ~title:"Saved" ~buttons
 510         q "The page was saved."
 511     );
 512
 513     no_errors
 514   in
 515
 516   let cancel id =
 517     let sth = dbh#prepare_cached "select url from pages
 518                                    where hostid = ? and id = ?" in
 519     sth#execute [`Int hostid; `Int id];
 520     let url = sth#fetch1string () in
 521
 522     q#redirect ("http://" ^ hostname ^ "/" ^ url)
 523   in
 524
 525   (* This codes decides where we are in the current editing cycle.
 526    *
 527    * Inputs:
 528    *   id - if set, then we are in the midst of editing a page.
 529    *   save - if set, then we want to save the page.
 530    *   cancel - if set, abandon changes and go back to viewing the page.
 531    *   action_* - one of the action buttons was set, eg. move up/down.
 532    *   page - the page URL opened newly for editing.
 533    *)
 534   (try
 535      let id = int_of_string (q#param "id") in
 536      if q#param_true "cancel" then (
 537        cancel id;
 538        return ()
 539      );
 540      if q#param_true "save" then (
 541        let ok = try_save () in
 542        if ok then return ()             (* ... else fall through *)
 543      );
 544      continue_editing ()                (* Processes the action, if any. *)
 545    with
 546        Not_found ->
 547          let page = q#param "page" in
 548          let page = if page = "" then "index" else page in
 549          begin_editing page);
 550
 551   q#template template
 552
 553 let () =
 554   register_script ~restrict:[CanEdit] run