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 $
16 open Cocanwiki_template
18 open Cocanwiki_emailnotify
19 open Cocanwiki_strings
21 let template = get_template "edit_sitemenu.html"
23 (* We keep an "internal model" of the menu - see build_internal_model ()
26 type model_t = (string * string) list (* label, url *)
28 let run r (q : cgi) (dbh : Dbi.connection) (hostid, hostname, _) _ =
29 (* Workaround bugs in IE, specifically lack of support for <button>
34 let ua = Table.get (Request.headers_in r) "User-Agent" in
35 ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
38 Not_found | String.Invalid_string -> false in
39 template#conditional "msie" msie;
41 (* Pull in the list of URLs in useful format. *)
42 let sth = dbh#prepare_cached "select url, title from pages
47 sth#execute [`Int hostid];
49 let urls = sth#map (function [`String url; `String title] ->
51 | _ -> assert false) in
53 (* Build the internal model from the parameters passed to the script. *)
54 let build_internal_model () =
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;
63 (List.rev !model : model_t)
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
72 (* XXX Not implemented yet. *)
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. *)
87 | n, x :: xs -> x :: (loop (n-1, xs))
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
101 | 2, x :: y :: xs -> y :: x :: xs
102 | n, x :: xs -> x :: (loop (n-1, xs))
106 let action_movedn model posn =
107 (* posn = 1 means move down the first element to the second position
114 | 1, x :: y :: xs -> y :: x :: xs
115 | n, x :: xs -> x :: (loop (n-1, xs))
119 let action_delete model posn =
120 (* posn = 1 means delete the first element *)
126 | n, x :: xs -> x :: (loop (n-1, xs))
131 (* Convert model to template. *)
132 let model_to_template model template =
133 let ordering = ref 0 in
137 incr ordering; let ordering = !ordering in
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
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;
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 <> [])
161 (* Begin editing a page, pulling the menu out of the database and building
164 let begin_editing () =
165 let sth = dbh#prepare_cached "select label, url, ordering
168 order by ordering" in
169 sth#execute [`Int hostid];
171 let model = sth#map (function [`String label; `String url; _] ->
173 | _ -> assert false) in
175 model_to_template model template
178 let continue_editing () =
179 let model = ref (build_internal_model ()) in
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.
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
196 if String.ends_with str ".x" then (
197 let str = String.sub str 0 (String.length str - 2) in
203 let action_type = String.sub str 7 6 in
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
209 let is_action typ = List.mem_assoc typ actions in
210 let get_value typ = List.assoc typ actions in
215 if is_action "insert" then (
216 let posn = get_action "insert" 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
230 model_to_template !model template
233 (* Try to save the page. Returns a boolean indicating if the
234 * page was saved successfully.
237 let model = build_internal_model () in
238 let no_errors = [] = check_for_errors model in
240 (* No errors, so we can save the page ... *)
242 let sth = dbh#prepare_cached "delete from sitemenu where hostid = ?" in
243 sth#execute [`Int hostid];
245 let sth = dbh#prepare_cached "insert into sitemenu (hostid, label, url,
246 ordering) values (?, ?, ?, ?)" in
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;
253 (* Commit changes to the database. *)
256 (* Email notification, if anyone is listed for this host. *)
257 let subject = "The site menu has been edited" in
259 let body = fun () -> "Site: http://" ^ hostname ^ "/\n\n" in
261 email_notify ~body ~subject dbh hostid;
263 let buttons = [ ok_button "/" ] in
264 ok ~title:"Saved" ~buttons
265 q "The site menu was saved."
272 q#redirect ("http://" ^ hostname ^ "/")
275 (* This codes decides where we are in the current editing cycle.
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.
284 if q#param_true "inedit" then (
285 if q#param_true "cancel" then (
289 if q#param_true "save" then (
290 let ok = try_save () in
291 if ok then raise CgiExit (* ... else fall through *)
293 continue_editing () (* Processes the action, if any. *)
300 register_script ~restrict:[CanEdit] run