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.8 2004/09/09 12:21:22 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
  36 (* We keep an "internal model" of the page - see build_internal_model ()
  37  * below.
  38  *)
  39 type model_t = {
  40   id : int;                             (* Original page ID. *)
  41   description : string;                 (* Description. *)
  42   redirect : string;                    (* Redirect to ("" = none). *)
  43   contents : (string * string * string) list;
  44                                         (* (sectionname, divname, content)
  45                                          * for each section. *)
  46 }
  47
  48 let run r (q : cgi) (dbh : Dbi.connection) hostid { hostname = hostname } _ =
  49   let template = get_template dbh hostid "edit.html" in
  50   let template_conflict = get_template dbh hostid "edit_conflict.html" in
  51
  52   (* Workaround bugs in IE, specifically lack of support for <button>
  53    * elements.
  54    *)
  55   let msie =
  56     try
  57       let ua = Table.get (Request.headers_in r) "User-Agent" in
  58       ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
  59       true
  60     with
  61         Not_found | String.Invalid_string -> false in
  62   template#conditional "msie" msie;
  63
  64   (* Build the internal model from the parameters passed to the script. *)
  65   let build_internal_model () =
  66     let id = int_of_string (q#param "id") in
  67     let description = q#param "description" in
  68     let redirect = q#param "redirect" in
  69
  70     let contents = ref [] in
  71     let i = ref 1 in
  72     while q#param_exists ("content_" ^ string_of_int !i) do
  73       let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
  74       let content = q#param ("content_" ^ string_of_int !i) in
  75       let divname = q#param ("divname_" ^ string_of_int !i) in
  76       contents := (sectionname, divname, content) :: !contents;
  77       incr i
  78     done;
  79     let contents = List.rev !contents in
  80
  81     { id = id;
  82       description = description;
  83       redirect = redirect;
  84       contents = contents; }
  85   in
  86
  87   (* Check for errors in the model. *)
  88   let check_for_errors model =
  89     let errors = ref [] in
  90     let add_error msg = errors := msg :: !errors in
  91     let get_errors () = List.rev !errors in
  92
  93     if model.redirect = "" then (
  94       (* Empty page? *)
  95       if model.contents = [] then
  96         add_error ("This page is empty.  Use 'Insert new section here' " ^
  97                    "to write something!");
  98
  99       (* Description field? *)
 100       if model.description = "" then
 101         add_error ("The description field is very important!  This field is " ^
 102                    "used by search engines and directories to describe " ^
 103                    "what's on this page.");
 104     )
 105     else (* it's a redirect *) (
 106       (* Redirect points to a real page? *)
 107       let sth = dbh#prepare_cached "select 1 from pages
 108                                      where hostid = ?
 109                                        and url is not null
 110                                        and url = ?
 111                                        and id <> ?
 112                                        and redirect is null" in
 113       sth#execute [`Int hostid; `String model.redirect; `Int model.id];
 114
 115       let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
 116       if not ok then
 117         add_error ("Redirect must point to an ordinary page " ^
 118                    "(ie. not to a page which is itself a redirect).")
 119     );
 120
 121     (* All sections have sectionnames? *)
 122     List.iter (function (sectionnames, _, _)
 123                    when string_is_whitespace sectionnames ->
 124                      add_error ("Every section must have a title.");
 125                  | _ -> ())
 126       model.contents;
 127
 128     get_errors ()
 129   in
 130
 131   (* Various "actions" that can be performed on the model. *)
 132   let action_insert model posn item =
 133     (* posn = 0 means insert before the first element of the current list. *)
 134     let rec loop =
 135       function
 136           0, xs -> item :: xs
 137         | _, [] -> [ item ]
 138         | n, x :: xs -> x :: (loop (n-1, xs))
 139     in
 140     let contents = loop (posn, model.contents) in
 141     { model with contents = contents }
 142   in
 143   let action_moveup model posn =
 144     (* posn = 1 means move up the first element, ie. do nothing
 145      * posn = 2 means move up the second element to the first position
 146      * etc.
 147      *)
 148     let rec loop =
 149       function
 150           0, xs
 151         | 1, xs -> xs
 152         | _, [] -> []
 153         | 2, x :: y :: xs -> y :: x :: xs
 154         | n, x :: xs -> x :: (loop (n-1, xs))
 155     in
 156     let contents = loop (posn, model.contents) in
 157     { model with contents = contents }
 158   in
 159   let action_movedn model posn =
 160     (* posn = 1 means move down the first element to the second position
 161      * etc.
 162      *)
 163     let rec loop =
 164       function
 165           0, xs -> xs
 166         | _, [] -> []
 167         | 1, x :: y :: xs -> y :: x :: xs
 168         | n, x :: xs -> x :: (loop (n-1, xs))
 169     in
 170     let contents = loop (posn, model.contents) in
 171     { model with contents = contents }
 172   in
 173   let action_delete model posn =
 174     (* posn = 1 means delete the first element *)
 175     let rec loop =
 176       function
 177           0, xs -> xs
 178         | _, [] -> []
 179         | 1, x :: xs -> xs
 180         | n, x :: xs -> x :: (loop (n-1, xs))
 181     in
 182     let contents = loop (posn, model.contents) in
 183     { model with contents = contents }
 184   in
 185
 186   (* Convert model to template. *)
 187   let model_to_template model template =
 188     template#set "id" (string_of_int model.id);
 189     template#set "description" model.description;
 190
 191     (* Redirects table. *)
 192     let sth = dbh#prepare_cached "select url, title from pages
 193                                    where url is not null
 194                                      and redirect is null
 195                                      and hostid = ? and id <> ?
 196                                    order by 2" in
 197     sth#execute [`Int hostid; `Int model.id];
 198     let table = sth#map (function [`String url; `String title] ->
 199                            let selected = model.redirect = url in
 200                            [ "url", Template.VarString url;
 201                              "title", Template.VarString title;
 202                              "selected", Template.VarConditional selected ]
 203                            | _ -> assert false) in
 204     template#table "redirects" table;
 205
 206     (* Need to go to the database to get the title of the page ... *)
 207     let sth = dbh#prepare_cached "select title from pages
 208                                    where hostid = ? and id = ?" in
 209     sth#execute [`Int hostid; `Int model.id];
 210     let title = sth#fetch1string () in
 211     template#set "title" title;
 212
 213     let ordering = ref 0 in
 214     let table =
 215       List.map
 216         (fun (sectionname, divname, content) ->
 217            incr ordering; let ordering = !ordering in
 218            [ "ordering", Template.VarString (string_of_int ordering);
 219              "sectionname", Template.VarString sectionname;
 220              "divname", Template.VarString divname;
 221              "content", Template.VarString content ]) model.contents in
 222     template#table "contents" table;
 223
 224     (* Check for errors and put those into the template. *)
 225     let errors = check_for_errors model in
 226     let errors = List.map (fun msg ->
 227                              [ "error", Template.VarString msg ]) errors in
 228     template#table "errors" errors;
 229     template#conditional "has_errors" (errors <> [])
 230   in
 231
 232   (* Begin editing a page, pulling the page out of the database and building
 233    * a model from it.
 234    *)
 235   let begin_editing page =
 236     (* Pull out the page itself from the database. *)
 237     let sth = dbh#prepare_cached "select id, title, description,
 238                                          coalesce (redirect, '')
 239                                     from pages
 240                                    where hostid = ? and url = ?" in
 241     sth#execute [`Int hostid; `String page];
 242
 243     let pageid, title, description, redirect =
 244       match sth#fetch1 () with
 245           [`Int pageid; `String title; `String description; `String redirect]->
 246             pageid, title, description, redirect
 247         | _ -> assert false in
 248
 249     (* Get the sections. *)
 250     let sth = dbh#prepare_cached "select sectionname, content,
 251                                          coalesce (divname, '')
 252                                     from contents
 253                                    where pageid = ?
 254                                    order by ordering" in
 255     sth#execute [`Int pageid];
 256
 257     let contents =
 258       sth#map (function
 259                  | [`String sectionname; `String content; `String divname] ->
 260                      sectionname, divname, content
 261                  | _ -> assert false) in
 262
 263     let model = { id = pageid;
 264                   description = description;
 265                   redirect = redirect;
 266                   contents = contents; } in
 267
 268     model_to_template model template
 269   in
 270
 271   let continue_editing () =
 272     let model = ref (build_internal_model ()) in
 273
 274     (* An "action" parameter? *)
 275     let is_action, get_action =
 276       let actions = q#params in
 277       (* Don't actually care about the value fields ... *)
 278       let actions = List.map (fun (str, _) -> str) actions in
 279       (* Some of our actions are imagemaps, so parameters like name.x, name.y
 280        * need to be changed to name and have resulting duplicates removed.
 281        *)
 282       let actions =
 283         List.filter (fun str ->
 284                        String.length str > 7 &&
 285                        String.sub str 0 7 = "action_" &&
 286                        not (String.ends_with str ".y")) actions in
 287       let actions =
 288         List.map (fun str ->
 289                     if String.ends_with str ".x" then (
 290                       let str = String.sub str 0 (String.length str - 2) in
 291                       str
 292                     )
 293                     else str) actions in
 294       let actions =
 295         List.map (fun str ->
 296                     let action_type = String.sub str 7 6 in
 297                     let action_value =
 298                       String.sub str 14 (String.length str - 14) in
 299                     let action_value = int_of_string action_value in
 300                     action_type, action_value) actions in
 301
 302       let is_action typ = List.mem_assoc typ actions in
 303       let get_value typ = List.assoc typ actions in
 304
 305       is_action, get_value
 306     in
 307
 308     if is_action "insert" then (
 309       let posn = get_action "insert" in
 310       let item = "New section - change this", "", "Write some content here." in
 311       model := action_insert !model posn item
 312     ) else if is_action "moveup" then (
 313       let posn = get_action "moveup" in
 314       model := action_moveup !model posn
 315     ) else if is_action "movedn" then (
 316       let posn = get_action "movedn" in
 317       model := action_movedn !model posn
 318     ) else if is_action "delete" then (
 319       let posn = get_action "delete" in
 320       model := action_delete !model posn
 321     );
 322
 323     model_to_template !model template
 324   in
 325
 326   (* Try to save the page.  Returns a boolean indicating if the
 327    * page was saved successfully.
 328    *)
 329   let try_save () =
 330     let model = build_internal_model () in
 331     let no_errors = [] = check_for_errors model in
 332     if no_errors then (
 333       (* No errors, so we can save the page ... *)
 334
 335       (* Pull out fields from the database. *)
 336       let sth = dbh#prepare_cached "select creation_date,
 337                                            coalesce (url, url_deleted),
 338                                            title, css
 339                                       from pages
 340                                      where hostid = ? and id = ?" in
 341       sth#execute [`Int hostid; `Int model.id];
 342
 343       let creation_date, url, title, css =
 344         match sth#fetch1 () with
 345             [ creation_date; `String url; `String title; css ] ->
 346               creation_date, url, title, css
 347           | _ -> assert false in
 348
 349       (* Has someone else edited this page in the meantime? *)
 350       let sth = dbh#prepare_cached "select max(id) from pages
 351                                      where hostid = ? and url = ?" in
 352       sth#execute [`Int hostid; `String url];
 353
 354       let max_id = sth#fetch1int () in
 355       let edited = max_id <> model.id in
 356
 357       if edited then (
 358         (* Edited by someone else ...  Get the other's changes. *)
 359         let other_diff, _ =
 360           get_diff dbh hostid url ~old_version:model.id ~version:max_id () in
 361
 362         (* Synthesize our own changes. *)
 363         let old_page = get_version_for_diff dbh model.id in
 364         let new_page =
 365           let css = match css with
 366               `Null -> "" | `String css -> css
 367             | _ -> assert false in
 368           page_for_diff css (List.map (fun (sectionname, _, content) ->
 369                                sectionname, content) model.contents) in
 370         let our_diff = diff_cmd old_page new_page in
 371
 372         (* Fill out the conflict template. *)
 373         template_conflict#set "other_diff" other_diff;
 374         template_conflict#set "our_diff" our_diff;
 375         template_conflict#set "old_version" (string_of_int model.id);
 376         template_conflict#set "new_version" (string_of_int max_id);
 377         template_conflict#set "url" url;
 378
 379         q#template template_conflict;
 380         raise CgiExit
 381       );
 382
 383       (* Defer the pages_redirect_cn constraint because that would
 384        * temporarily fail on the next UPDATE.
 385        *)
 386       let sth =
 387         dbh#prepare_cached
 388           "set constraints pages_redirect_cn, sitemenu_url_cn deferred" in
 389       sth#execute [];
 390
 391       (* Mark the old page as deleted.  NB. There is a small race
 392        * condition here because PostgreSQL doesn't do isolation
 393        * properly.  If a user tries to visit this page between the
 394        * delete and the creation of the new page, then they'll get
 395        * a page not found error. (XXX)
 396        *)
 397       let sth = dbh#prepare_cached "update pages set url_deleted = url,
 398                                                      url = null
 399                                      where hostid = ? and id = ?" in
 400       sth#execute [`Int hostid; `Int model.id];
 401
 402       (* Get the IP address of the user, if available. *)
 403       let logged_ip =
 404         try `String (Connection.remote_ip (Request.connection r))
 405         with Not_found -> `Null in
 406
 407       (* Get redirect. *)
 408       let redirect = if model.redirect = "" then `Null
 409                      else `String model.redirect in
 410
 411       (* Create the new page. *)
 412       let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
 413                                       description, creation_date, logged_ip,
 414                                       redirect, css)
 415                                     values (?, ?, ?, ?, ?, ?, ?, ?)" in
 416       sth#execute [`Int hostid; `String url; `String title;
 417                    `String model.description; creation_date; logged_ip;
 418                    redirect; css];
 419
 420       (* New page ID <> old page ID model.id. *)
 421       let pageid = sth#serial "pages_id_seq" in
 422
 423       (* Create the page contents. *)
 424       let sth = dbh#prepare_cached "insert into contents (pageid,
 425                                       ordering, sectionname, divname, content)
 426                                     values (?, ?, ?, ?, ?)" in
 427       let ordering = ref 0 in           (* Creating new ordering. *)
 428       List.iter (fun (sectionname, divname, content) ->
 429                    let divname =
 430                      if string_is_whitespace divname then `Null
 431                      else `String divname in
 432                    incr ordering; let ordering = !ordering in
 433                    sth#execute [`Int pageid; `Int ordering;
 434                                 `String sectionname; divname;
 435                                 `String content])
 436         model.contents;
 437
 438       (* Commit changes to the database. *)
 439       dbh#commit ();
 440
 441       (* Email notification, if anyone is listed for this host. *)
 442       let subject = "Page " ^ url ^ " has been edited" in
 443
 444       let body = fun () ->
 445         (* Prepare the diff between this version and the previous version. *)
 446         let diff, _ = get_diff dbh hostid url ~version:pageid () in
 447         "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
 448         diff in
 449
 450       email_notify ~body ~subject dbh hostid;
 451
 452       let buttons = [ ok_button ("/" ^ url) ] in
 453       ok ~title:"Saved" ~buttons
 454         q "The page was saved."
 455     );
 456
 457     no_errors
 458   in
 459
 460   let cancel id =
 461     let sth = dbh#prepare_cached "select url from pages
 462                                    where hostid = ? and id = ?" in
 463     sth#execute [`Int hostid; `Int id];
 464     let url = sth#fetch1string () in
 465
 466     q#redirect ("http://" ^ hostname ^ "/" ^ url)
 467   in
 468
 469   (* This codes decides where we are in the current editing cycle.
 470    *
 471    * Inputs:
 472    *   id - if set, then we are in the midst of editing a page.
 473    *   save - if set, then we want to save the page.
 474    *   cancel - if set, abandon changes and go back to viewing the page.
 475    *   action_* - one of the action buttons was set, eg. move up/down.
 476    *   page - the page URL opened newly for editing.
 477    *)
 478   (try
 479      let id = int_of_string (q#param "id") in
 480      if q#param_true "cancel" then (
 481        cancel id;
 482        raise CgiExit
 483      );
 484      if q#param_true "save" then (
 485        let ok = try_save () in
 486        if ok then raise CgiExit         (* ... else fall through *)
 487      );
 488      continue_editing ()                (* Processes the action, if any. *)
 489    with
 490        Not_found ->
 491          let page = q#param "page" in
 492          let page = if page = "" then "index" else page in
 493          begin_editing page);
 494
 495   q#template template
 496
 497 let () =
 498   register_script ~restrict:[CanEdit] run