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