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