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.35 2006/08/04 12:45:31 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 keywords = q#param "keywords" in
  59     let keywords =
  60       if string_is_whitespace keywords then None else Some keywords in
  61     let redirect = q#param "redirect" in
  62     let redirect =
  63       if string_is_whitespace redirect then None else Some redirect in
  64     let pt = match q#param "pt_type" with
  65       | "page" -> Page (q#param "pt_value")
  66       | "title" -> Title (q#param "pt_value")
  67       | _ -> failwith "unknown value for pt_type parameter" in
  68
  69     let contents = ref [] in
  70     let i = ref 1 in
  71     while q#param_exists ("content_" ^ string_of_int !i) do
  72       let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
  73       let sectionname =
  74         if string_is_whitespace sectionname then None else Some sectionname in
  75       let content = q#param ("content_" ^ string_of_int !i) in
  76       let divname = q#param ("divname_" ^ string_of_int !i) in
  77       let divname =
  78         if string_is_whitespace divname then None else Some divname in
  79       let jsgo = q#param ("jsgo_" ^ string_of_int !i) in
  80       let jsgo = if string_is_whitespace jsgo then None else Some jsgo in
  81       contents := (sectionname, divname, jsgo, content) :: !contents;
  82       incr i
  83     done;
  84     let contents = List.rev !contents in
  85
  86     { id = id;
  87       pt = pt;
  88       description = description;
  89       keywords = keywords;
  90       redirect = redirect;
  91       contents_ = contents; }
  92   in
  93
  94   (* Check for errors in the model. *)
  95   let check_for_errors model =
  96     let errors = ref [] in
  97     let add_error msg = errors := msg :: !errors in
  98     let get_errors () = List.rev !errors in
  99
 100     (match model.redirect with
 101      | None ->
 102          (* Empty page? *)
 103          if model.contents_ = [] then
 104            add_error ("This page is empty.  Use 'Insert new section here' " ^
 105                         "to write something!");
 106
 107          (* Description field? *)
 108          if model.description = "" then
 109            add_error ("The description field is very important!  " ^
 110                         "This field is " ^
 111                         "used by search engines and directories to describe " ^
 112                         "what's on this page.");
 113
 114      | Some redirect ->
 115          (* Redirect points to a real page? *)
 116          let rows =
 117            let model_id = model.id in
 118            PGSQL(dbh)
 119            "select 1 from pages
 120              where hostid = $hostid and url is not null
 121                and url = $redirect and id <> $model_id
 122                and redirect is null" in
 123
 124          let ok = rows = [Some 1l] in
 125          if not ok then
 126            add_error ("Redirect must point to an ordinary page " ^
 127                         "(ie. not to a page which is itself a redirect).")
 128     );
 129
 130     (* All sections after the first one have sectionnames?  The first
 131      * section ONLY is allowed to have an empty title.
 132      *)
 133     if model.contents_ <> [] then
 134       List.iter (function
 135                  | (None, _, _, _) ->
 136                      add_error
 137                        "Every section except the first must have a title.";
 138                  | _ -> ())
 139         (List.tl model.contents_);
 140
 141     (* There are two constraints on any non-null jsgo's:
 142      * (1) Must only be present if divname is non-null.
 143      * (2) Must point to a valid URL on the current host.
 144      *)
 145     List.iter (
 146       function
 147       | (_, None, Some _, _) ->
 148           add_error
 149             "Javascript onclick can only be used with a CSS id."
 150       | (_, _, Some jsgo, _) ->
 151           let rows =
 152             PGSQL(dbh) "select 1 from pages
 153                          where hostid = $hostid
 154                            and url is not null
 155                            and url = $jsgo
 156                            and redirect is null" in
 157           let ok = rows = [Some 1l] in
 158           if not ok then
 159             add_error ("Javascript onclick must point to an ordinary page " ^
 160                        "on the current site (ie. not to a redirect). " ^
 161                        "Do not put '/' at the beginning of the URL.")
 162       | _ -> ()
 163     ) model.contents_;
 164
 165     get_errors ()
 166   in
 167
 168   (* Various "actions" that can be performed on the model. *)
 169   let action_insert model posn item =
 170     (* posn = 0 means insert before the first element of the current list. *)
 171     let rec loop =
 172       function
 173           0, xs -> item :: xs
 174         | _, [] -> [ item ]
 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_moveup model posn =
 181     (* posn = 1 means move up the first element, ie. do nothing
 182      * posn = 2 means move up the second element to the first position
 183      * etc.
 184      *)
 185     let rec loop =
 186       function
 187           0, xs
 188         | 1, xs -> xs
 189         | _, [] -> []
 190         | 2, x :: y :: xs -> y :: x :: xs
 191         | n, x :: xs -> x :: (loop (n-1, xs))
 192     in
 193     let contents = loop (posn, model.contents_) in
 194     { model with contents_ = contents }
 195   in
 196   let action_movedn model posn =
 197     (* posn = 1 means move down the first element to the second position
 198      * etc.
 199      *)
 200     let rec loop =
 201       function
 202           0, xs -> xs
 203         | _, [] -> []
 204         | 1, x :: y :: xs -> y :: x :: xs
 205         | n, x :: xs -> x :: (loop (n-1, xs))
 206     in
 207     let contents = loop (posn, model.contents_) in
 208     { model with contents_ = contents }
 209   in
 210   let action_delete model posn =
 211     (* posn = 1 means delete the first element *)
 212     let rec loop =
 213       function
 214           0, xs -> xs
 215         | _, [] -> []
 216         | 1, x :: xs -> xs
 217         | n, x :: xs -> x :: (loop (n-1, xs))
 218     in
 219     let contents = loop (posn, model.contents_) in
 220     { model with contents_ = contents }
 221   in
 222
 223   (* Convert model to template. *)
 224   let model_to_template model template =
 225     template#set "id" (Int32.to_string model.id);
 226     template#set "description" model.description;
 227     template#set "keywords"
 228       (match model.keywords with None -> "" | Some keywords -> keywords);
 229
 230     (match model.pt with
 231          Page page ->
 232            template#set "pt_type" "page";
 233            template#set "pt_value" page
 234        | Title title ->
 235            template#set "pt_type" "title";
 236            template#set "pt_value" title);
 237
 238     (* Redirects table. *)
 239     let rows =
 240       let model_id = model.id in
 241       PGSQL(dbh)
 242       "select url, title from pages
 243         where url is not null
 244           and redirect is null
 245           and hostid = $hostid and id <> $model_id
 246         order by 2" in
 247     let table = List.map (
 248       fun (url, title) ->
 249         let url = Option.get url in
 250         let is_index = url = "index" in
 251         let selected = model.redirect = Some url in
 252         [ "url", Template.VarString url;
 253           "title", Template.VarString title;
 254           "selected", Template.VarConditional selected;
 255           "is_index", Template.VarConditional is_index ]
 256     ) rows in
 257     template#table "redirects" table;
 258
 259     if model.id <> 0l then (
 260       (* Need to go to the database to get the title of the page ... *)
 261       let rows =
 262         let model_id = model.id in
 263         PGSQL(dbh)
 264           "select title from pages
 265             where hostid = $hostid and id = $model_id" in
 266       let title = List.hd rows in
 267       template#set "title" title;
 268     ) else (
 269       match model.pt with
 270       | Page page -> template#set "title" page
 271       | Title title -> template#set "title" title
 272     );
 273
 274     let ordering = ref 0 in
 275     let table =
 276       List.map
 277         (fun (sectionname, divname, jsgo, content) ->
 278            incr ordering; let ordering = Int32.of_int !ordering in
 279            let sectionname = match sectionname with None -> "" | Some s -> s in
 280            let divname = match divname with None -> "" | Some s -> s in
 281            let jsgo = match jsgo with None -> "" | Some s -> s in
 282            [ "ordering", Template.VarString (Int32.to_string ordering);
 283              "sectionname", Template.VarString sectionname;
 284              "divname", Template.VarString divname;
 285              "jsgo", Template.VarString jsgo;
 286              "content", Template.VarString content ]) model.contents_ in
 287     template#table "contents" table;
 288
 289     (* Check for errors and put those into the template. *)
 290     let errors = check_for_errors model in
 291     let errors = List.map (fun msg ->
 292                              [ "error", Template.VarString msg ]) errors in
 293     template#table "errors" errors;
 294     template#conditional "has_errors" (errors <> [])
 295   in
 296
 297   (* Check if a URL exists in the database. *)
 298   let page_exists page =
 299     let rows = PGSQL(dbh)
 300       "select 1 from pages where hostid = $hostid and url = $page" in
 301     rows = [ Some 1l ]
 302   in
 303
 304   (* Begin editing a page, pulling the page out of the database and building
 305    * a model from it.
 306    *)
 307   let begin_editing page =
 308     let model = load_page dbh hostid ~url:page () in
 309     model_to_template model template
 310   in
 311
 312   (* Begin editing with a blank page, typically a template. *)
 313   let begin_editing_new pt =
 314     (* Just check the title. *)
 315     (match pt with
 316      | Page url -> ()
 317      | Title title ->
 318          match Wikilib.generate_url_of_title r dbh hostid title with
 319          | Wikilib.GenURL_OK url -> ()
 320          | Wikilib.GenURL_Duplicate url ->
 321              q#redirect ("http://" ^ hostname ^ "/" ^ url)
 322          | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
 323              error ~back_button:true ~title:"Bad page name"
 324                dbh hostid q
 325                "The page name supplied is too short or invalid.";
 326              return ()
 327     );
 328
 329     let model = match pt with
 330       | Page url -> new_page pt
 331       | Title title -> new_page_with_title title in
 332
 333     model_to_template model template
 334   in
 335
 336   let continue_editing () =
 337     let model = ref (build_internal_model ()) in
 338
 339     (* An "action" parameter? *)
 340     let is_action, get_action =
 341       let actions = q#params in
 342       (* Don't actually care about the value fields ... *)
 343       let actions = List.map (fun (str, _) -> str) actions in
 344       (* Some of our actions are imagemaps, so parameters like name.x, name.y
 345        * need to be changed to name and have resulting duplicates removed.
 346        *)
 347       let actions =
 348         List.filter (fun str ->
 349                        String.length str > 7 &&
 350                        String.sub str 0 7 = "action_" &&
 351                        not (String.ends_with str ".y")) actions in
 352       let actions =
 353         List.map (fun str ->
 354                     if String.ends_with str ".x" then (
 355                       let str = String.sub str 0 (String.length str - 2) in
 356                       str
 357                     )
 358                     else str) actions in
 359       let actions =
 360         List.map (fun str ->
 361                     let action_type = String.sub str 7 6 in
 362                     let action_value =
 363                       String.sub str 14 (String.length str - 14) in
 364                     let action_value = int_of_string action_value in
 365                     action_type, action_value) actions in
 366
 367       let is_action typ = List.mem_assoc typ actions in
 368       let get_value typ = List.assoc typ actions in
 369
 370       is_action, get_value
 371     in
 372
 373     if is_action "insert" then (
 374       let posn = get_action "insert" in
 375       let item =
 376         Some "The title of this section",
 377         None, None,
 378         "Write something here." in
 379       model := action_insert !model posn item
 380     ) else if is_action "moveup" then (
 381       let posn = get_action "moveup" in
 382       model := action_moveup !model posn
 383     ) else if is_action "movedn" then (
 384       let posn = get_action "movedn" in
 385       model := action_movedn !model posn
 386     ) else if is_action "delete" then (
 387       let posn = get_action "delete" in
 388       model := action_delete !model posn
 389     );
 390
 391     model_to_template !model template
 392   in
 393
 394   (* Try to save the page.  Only returns if there were errors in
 395    * the model.
 396    *)
 397   let try_save () =
 398     let model = build_internal_model () in
 399     let no_errors = [] = check_for_errors model in
 400     if no_errors then (
 401       (* No errors, so we can save the page ... *)
 402       let url, pageid =
 403         try
 404           save_page r dbh hostid ~user model
 405         with
 406             SaveURLError ->
 407               error ~back_button:true ~title:"Page exists"
 408                 dbh hostid q ("While you were editing that page, it looks " ^
 409                               "like another user created the same page.");
 410               return ()
 411
 412           | SaveConflict (new_version, old_version, url, css) ->
 413               (* Edited by someone else ...  Get the other's changes. *)
 414               let other_diff, _ =
 415                 get_diff dbh hostid url ~old_version ~version:new_version () in
 416
 417               (* Synthesize our own changes. *)
 418               let old_page = get_version_for_diff dbh old_version in
 419               let new_page =
 420                 page_for_diff model css in
 421               let our_diff = diff_cmd old_page new_page in
 422
 423               (* Fill out the conflict template. *)
 424               template_conflict#set "other_diff" other_diff;
 425               template_conflict#set "our_diff" our_diff;
 426               template_conflict#set "old_version"
 427                 (Int32.to_string old_version);
 428               template_conflict#set "new_version"
 429                 (Int32.to_string new_version);
 430               template_conflict#set "url" url;
 431
 432               q#template template_conflict;
 433               return () in
 434
 435       (* General email notification of page edits.  Send an email to
 436        * anyone in the page_emails table who has a confirmed address
 437        * and who hasn't received an email already today.
 438        *)
 439       let rows = PGSQL(dbh)
 440         "select email, opt_out from page_emails
 441           where hostid = $hostid and url = $url
 442             and pending is null
 443             and last_sent < current_date" in
 444       let addrs = List.map (
 445         fun (email, opt_out) ->
 446           email, opt_out
 447       ) rows in
 448
 449       if addrs <> [] then (
 450         (* Construct the email. *)
 451         template_email#set "hostname" hostname;
 452         template_email#set "page" url;
 453
 454         let subject =
 455           "Site notice: " ^ hostname ^ "/" ^ url ^ " has been updated" in
 456
 457         let content_type =
 458           "text/plain", ["charset", Mimestring.mk_param "UTF-8"] in
 459
 460         (* Send each email individually (they all have different opt out
 461          * links).
 462          *)
 463         List.iter (fun (to_addr, opt_out) ->
 464                      template_email#set "opt_out" opt_out;
 465                      let body = template_email#to_string in
 466
 467                      let msg = Netsendmail.compose ~to_addrs:["", to_addr]
 468                        ~subject ~content_type body in
 469                      Netsendmail.sendmail msg)
 470           addrs
 471       );
 472
 473       (* Update the database to record when these emails were sent. *)
 474       PGSQL(dbh)
 475         "update page_emails
 476             set last_sent = current_date
 477           where hostid = $hostid and url = $url
 478             and pending is null";
 479
 480       (* Commit changes to the database. *)
 481       PGOCaml.commit dbh;
 482
 483       (* Email notification, if anyone is listed for this host. *)
 484       let subject = "Page " ^ url ^ " has been edited" in
 485
 486       let body = fun () ->
 487         (* Prepare the diff between this version and the previous version. *)
 488         let diff, _ = get_diff dbh hostid url ~version:pageid () in
 489         "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
 490         diff in
 491
 492       email_notify ~body ~subject ~user dbh hostid;
 493
 494       (* Redirect back to the URL. *)
 495       q#redirect ("http://" ^ hostname ^ "/" ^ url)
 496     );
 497   in
 498
 499   let cancel id =
 500     let url =
 501       if id <> 0l then (
 502         let rows = PGSQL(dbh)
 503           "select coalesce (url, url_deleted)
 504              from pages
 505             where hostid = $hostid and id = $id" in
 506         Option.get (List.hd rows)
 507       ) else if q#param "pt_type" = "page" then
 508         q#param "pt_value"
 509       else
 510         (* Create a new page, but the user hits the cancel button.  Because
 511          * we didn't save where they came from, we now have nowhere to
 512          * go.  So we redirect to the home page. XXX
 513          *)
 514         "" in
 515
 516     q#redirect ("http://" ^ hostname ^ "/" ^ url)
 517   in
 518
 519   (* This code decides where we are in the current editing cycle.
 520    *
 521    * Inputs:
 522    *   id - if set, then we are in the midst of editing a page.
 523    *   save - if set, then we want to save the page.
 524    *   cancel - if set, abandon changes and go back to viewing the page.
 525    *   action_* - one of the action buttons was set, eg. move up/down.
 526    *   page - the page URL opened newly for editing, or a template which
 527    *          doesn't yet exist.
 528    *   title - page doesn't yet exist; create it.
 529    *)
 530   let id =
 531     try Some (Int32.of_string (q#param "id")) with Not_found -> None in
 532   (match id with
 533      | None ->                          (* Begin editing the page. *)
 534          if q#param_exists "page" then (
 535            let page = q#param "page" in
 536            let page = if page = "" then "index" else page in
 537            if page_exists page then
 538              begin_editing page
 539            else
 540              begin_editing_new (Page page)
 541          ) else (
 542            let title = q#param "title" in
 543            begin_editing_new (Title title)
 544          )
 545
 546      | Some id ->
 547          if q#param_true "cancel" then
 548            cancel id;
 549          if q#param_true "save" then
 550            try_save ();                 (* might fail and fall through ... *)
 551          continue_editing ()
 552   );
 553
 554   q#template template
 555
 556 let () =
 557   register_script ~restrict:[CanEdit] run