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