scripts/edit.ml

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