scripts/edit_sitemenu.ml

   1 (* COCANWIKI scripts.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: edit_sitemenu.ml,v 1.1 2004/09/08 14:47:47 rich Exp $
   5  *)
   6
   7 open Apache
   8 open Registry
   9 open Cgi
  10 open Printf
  11
  12 open ExtString
  13 open ExtList
  14
  15 open Cocanwiki
  16 open Cocanwiki_template
  17 open Cocanwiki_ok
  18 open Cocanwiki_emailnotify
  19 open Cocanwiki_strings
  20
  21 let template = get_template "edit_sitemenu.html"
  22
  23 (* We keep an "internal model" of the menu - see build_internal_model ()
  24  * below.
  25  *)
  26 type model_t = (string * string) list   (* label, url *)
  27
  28 let run r (q : cgi) (dbh : Dbi.connection) (hostid, hostname, _) _ =
  29   (* Workaround bugs in IE, specifically lack of support for <button>
  30    * elements.
  31    *)
  32   let msie =
  33     try
  34       let ua = Table.get (Request.headers_in r) "User-Agent" in
  35       ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
  36       true
  37     with
  38         Not_found | String.Invalid_string -> false in
  39   template#conditional "msie" msie;
  40
  41   (* Pull in the list of URLs in useful format. *)
  42   let sth = dbh#prepare_cached "select url, title from pages
  43                                  where hostid = ?
  44                                    and url is not null
  45                                    and url <> 'index'
  46                                  order by 2" in
  47   sth#execute [`Int hostid];
  48
  49   let urls = sth#map (function [`String url; `String title] ->
  50                         url, title
  51                         | _ -> assert false) in
  52
  53   (* Build the internal model from the parameters passed to the script. *)
  54   let build_internal_model () =
  55     let model = ref [] in
  56     let i = ref 1 in
  57     while q#param_exists ("label_" ^ string_of_int !i) do
  58       let label = q#param ("label_" ^ string_of_int !i) in
  59       let url = q#param ("url_" ^ string_of_int !i) in
  60       model := (label, url) :: !model;
  61       incr i
  62     done;
  63     (List.rev !model : model_t)
  64   in
  65
  66   (* Check for errors in the model. *)
  67   let check_for_errors model =
  68     let errors = ref [] in
  69     let add_error msg = errors := msg :: !errors in
  70     let get_errors () = List.rev !errors in
  71
  72     (* XXX Not implemented yet. *)
  73
  74
  75
  76
  77     get_errors ()
  78   in
  79
  80   (* Various "actions" that can be performed on the model. *)
  81   let action_insert model posn item =
  82     (* posn = 0 means insert before the first element of the current list. *)
  83     let rec loop =
  84       function
  85           0, xs -> item :: xs
  86         | _, [] -> [ item ]
  87         | n, x :: xs -> x :: (loop (n-1, xs))
  88     in
  89     loop (posn, model)
  90   in
  91   let action_moveup model posn =
  92     (* posn = 1 means move up the first element, ie. do nothing
  93      * posn = 2 means move up the second element to the first position
  94      * etc.
  95      *)
  96     let rec loop =
  97       function
  98           0, xs
  99         | 1, xs -> xs
 100         | _, [] -> []
 101         | 2, x :: y :: xs -> y :: x :: xs
 102         | n, x :: xs -> x :: (loop (n-1, xs))
 103     in
 104     loop (posn, model)
 105   in
 106   let action_movedn model posn =
 107     (* posn = 1 means move down the first element to the second position
 108      * etc.
 109      *)
 110     let rec loop =
 111       function
 112           0, xs -> xs
 113         | _, [] -> []
 114         | 1, x :: y :: xs -> y :: x :: xs
 115         | n, x :: xs -> x :: (loop (n-1, xs))
 116     in
 117     loop (posn, model)
 118   in
 119   let action_delete model posn =
 120     (* posn = 1 means delete the first element *)
 121     let rec loop =
 122       function
 123           0, xs -> xs
 124         | _, [] -> []
 125         | 1, x :: xs -> xs
 126         | n, x :: xs -> x :: (loop (n-1, xs))
 127     in
 128     loop (posn, model)
 129   in
 130
 131   (* Convert model to template. *)
 132   let model_to_template model template =
 133     let ordering = ref 0 in
 134     let table =
 135       List.map
 136         (fun (label, url) ->
 137            incr ordering; let ordering = !ordering in
 138
 139            let table =
 140              List.map
 141                (fun (u, title) ->
 142                   let selected = u = url in
 143                   [ "url", Template.VarString u;
 144                     "title", Template.VarString (truncate 30 title);
 145                     "selected", Template.VarConditional selected ]) urls in
 146
 147            [ "ordering", Template.VarString (string_of_int ordering);
 148              "label", Template.VarString label;
 149              "url", Template.VarString url;
 150              "urls", Template.VarTable table; ]) model in
 151     template#table "contents" table;
 152
 153     (* Check for errors and put those into the template. *)
 154     let errors = check_for_errors model in
 155     let errors = List.map (fun msg ->
 156                              [ "error", Template.VarString msg ]) errors in
 157     template#table "errors" errors;
 158     template#conditional "has_errors" (errors <> [])
 159   in
 160
 161   (* Begin editing a page, pulling the menu out of the database and building
 162    * a model from it.
 163    *)
 164   let begin_editing () =
 165     let sth = dbh#prepare_cached "select label, url, ordering
 166                                     from sitemenu
 167                                    where hostid = ?
 168                                    order by ordering" in
 169     sth#execute [`Int hostid];
 170
 171     let model = sth#map (function [`String label; `String url; _] ->
 172                            label, url
 173                            | _ -> assert false) in
 174
 175     model_to_template model template
 176   in
 177
 178   let continue_editing () =
 179     let model = ref (build_internal_model ()) in
 180
 181     (* An "action" parameter? *)
 182     let is_action, get_action =
 183       let actions = q#params in
 184       (* Don't actually care about the value fields ... *)
 185       let actions = List.map (fun (str, _) -> str) actions in
 186       (* Some of our actions are imagemaps, so parameters like name.x, name.y
 187        * need to be changed to name and have resulting duplicates removed.
 188        *)
 189       let actions =
 190         List.filter (fun str ->
 191                        String.length str > 7 &&
 192                        String.sub str 0 7 = "action_" &&
 193                        not (String.ends_with str ".y")) actions in
 194       let actions =
 195         List.map (fun str ->
 196                     if String.ends_with str ".x" then (
 197                       let str = String.sub str 0 (String.length str - 2) in
 198                       str
 199                     )
 200                     else str) actions in
 201       let actions =
 202         List.map (fun str ->
 203                     let action_type = String.sub str 7 6 in
 204                     let action_value =
 205                       String.sub str 14 (String.length str - 14) in
 206                     let action_value = int_of_string action_value in
 207                     action_type, action_value) actions in
 208
 209       let is_action typ = List.mem_assoc typ actions in
 210       let get_value typ = List.assoc typ actions in
 211
 212       is_action, get_value
 213     in
 214
 215     if is_action "insert" then (
 216       let posn = get_action "insert" in
 217       let item = "", "" in
 218       model := action_insert !model posn item
 219     ) else if is_action "moveup" then (
 220       let posn = get_action "moveup" in
 221       model := action_moveup !model posn
 222     ) else if is_action "movedn" then (
 223       let posn = get_action "movedn" in
 224       model := action_movedn !model posn
 225     ) else if is_action "delete" then (
 226       let posn = get_action "delete" in
 227       model := action_delete !model posn
 228     );
 229
 230     model_to_template !model template
 231   in
 232
 233   (* Try to save the page.  Returns a boolean indicating if the
 234    * page was saved successfully.
 235    *)
 236   let try_save () =
 237     let model = build_internal_model () in
 238     let no_errors = [] = check_for_errors model in
 239     if no_errors then (
 240       (* No errors, so we can save the page ... *)
 241
 242       let sth = dbh#prepare_cached "delete from sitemenu where hostid = ?" in
 243       sth#execute [`Int hostid];
 244
 245       let sth = dbh#prepare_cached "insert into sitemenu (hostid, label, url,
 246                                     ordering) values (?, ?, ?, ?)" in
 247
 248       List.iteri (fun i (label, url) ->
 249                     let ordering = 10 * (i+1) in
 250                     sth#execute [`Int hostid; `String label; `String url;
 251                                  `Int ordering]) model;
 252
 253       (* Commit changes to the database. *)
 254       dbh#commit ();
 255
 256       (* Email notification, if anyone is listed for this host. *)
 257       let subject = "The site menu has been edited" in
 258
 259       let body = fun () -> "Site: http://" ^ hostname ^ "/\n\n" in
 260
 261       email_notify ~body ~subject dbh hostid;
 262
 263       let buttons = [ ok_button "/" ] in
 264       ok ~title:"Saved" ~buttons
 265         q "The site menu was saved."
 266     );
 267
 268     no_errors
 269   in
 270
 271   let cancel () =
 272     q#redirect ("http://" ^ hostname ^ "/")
 273   in
 274
 275   (* This codes decides where we are in the current editing cycle.
 276    *
 277    * Inputs:
 278    *   inedit - if set, then we are in the midst of editing a page.
 279    *   save - if set, then we want to save the page.
 280    *   cancel - if set, abandon changes and go back to viewing the page.
 281    *   action_* - one of the action buttons was set, eg. move up/down.
 282    *   page - the page URL opened newly for editing.
 283    *)
 284   if q#param_true "inedit" then (
 285     if q#param_true "cancel" then (
 286       cancel ();
 287       raise CgiExit
 288     );
 289     if q#param_true "save" then (
 290       let ok = try_save () in
 291       if ok then raise CgiExit          (* ... else fall through *)
 292     );
 293     continue_editing ()                 (* Processes the action, if any. *)
 294   ) else
 295     begin_editing ();
 296
 297   q#template template
 298
 299 let () =
 300   register_script ~restrict:[CanEdit] run