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