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_sitemenu.ml,v 1.8 2004/12/01 13:55:55 rich Exp $
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.
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.
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.
31 open Cocanwiki_template
33 open Cocanwiki_emailnotify
34 open Cocanwiki_strings
36 (* We keep an "internal model" of the menu - see build_internal_model ()
39 type model_t = (string * string) list (* label, url *)
41 let run r (q : cgi) (dbh : Dbi.connection) hostid { hostname = hostname } user=
42 let template = get_template dbh hostid "edit_sitemenu.html" in
44 (* Workaround bugs in IE, specifically lack of support for <button>
49 let ua = Table.get (Request.headers_in r) "User-Agent" in
50 ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
53 Not_found | Invalid_string -> false in
54 template#conditional "msie" msie;
56 (* Pull in the list of URLs in useful format. *)
57 let sth = dbh#prepare_cached "select url, title from pages
62 sth#execute [`Int hostid];
64 let urls = sth#map (function [`String url; `String title] ->
66 | _ -> assert false) in
68 (* Build the internal model from the parameters passed to the script. *)
69 let build_internal_model () =
72 while q#param_exists ("label_" ^ string_of_int !i) do
73 let label = q#param ("label_" ^ string_of_int !i) in
74 let url = q#param ("url_" ^ string_of_int !i) in
75 model := (label, url) :: !model;
78 (List.rev !model : model_t)
81 (* Check for errors in the model. *)
82 let check_for_errors model =
83 let errors = ref [] in
84 let add_error msg = errors := msg :: !errors in
85 let get_errors () = List.rev !errors in
87 (* XXX Not implemented yet. *)
95 (* Various "actions" that can be performed on the model. *)
96 let action_insert model posn item =
97 (* posn = 0 means insert before the first element of the current list. *)
102 | n, x :: xs -> x :: (loop (n-1, xs))
106 let action_moveup model posn =
107 (* posn = 1 means move up the first element, ie. do nothing
108 * posn = 2 means move up the second element to the first position
116 | 2, x :: y :: xs -> y :: x :: xs
117 | n, x :: xs -> x :: (loop (n-1, xs))
121 let action_movedn model posn =
122 (* posn = 1 means move down the first element to the second position
129 | 1, x :: y :: xs -> y :: x :: xs
130 | n, x :: xs -> x :: (loop (n-1, xs))
134 let action_delete model posn =
135 (* posn = 1 means delete the first element *)
141 | n, x :: xs -> x :: (loop (n-1, xs))
146 (* Convert model to template. *)
147 let model_to_template model template =
148 let ordering = ref 0 in
152 incr ordering; let ordering = !ordering in
157 let selected = u = url in
158 [ "url", Template.VarString u;
159 "title", Template.VarString (truncate 30 title);
160 "selected", Template.VarConditional selected ]) urls in
162 [ "ordering", Template.VarString (string_of_int ordering);
163 "label", Template.VarString label;
164 "url", Template.VarString url;
165 "urls", Template.VarTable table; ]) model in
166 template#table "contents" table;
168 (* Check for errors and put those into the template. *)
169 let errors = check_for_errors model in
170 let errors = List.map (fun msg ->
171 [ "error", Template.VarString msg ]) errors in
172 template#table "errors" errors;
173 template#conditional "has_errors" (errors <> [])
176 (* Begin editing a page, pulling the menu out of the database and building
179 let begin_editing () =
180 let sth = dbh#prepare_cached "select label, url, ordering
183 order by ordering" in
184 sth#execute [`Int hostid];
186 let model = sth#map (function [`String label; `String url; _] ->
188 | _ -> assert false) in
190 model_to_template model template
193 let continue_editing () =
194 let model = ref (build_internal_model ()) in
196 (* An "action" parameter? *)
197 let is_action, get_action =
198 let actions = q#params in
199 (* Don't actually care about the value fields ... *)
200 let actions = List.map (fun (str, _) -> str) actions in
201 (* Some of our actions are imagemaps, so parameters like name.x, name.y
202 * need to be changed to name and have resulting duplicates removed.
205 List.filter (fun str ->
206 String.length str > 7 &&
207 String.sub str 0 7 = "action_" &&
208 not (String.ends_with str ".y")) actions in
211 if String.ends_with str ".x" then (
212 let str = String.sub str 0 (String.length str - 2) in
218 let action_type = String.sub str 7 6 in
220 String.sub str 14 (String.length str - 14) in
221 let action_value = int_of_string action_value in
222 action_type, action_value) actions in
224 let is_action typ = List.mem_assoc typ actions in
225 let get_value typ = List.assoc typ actions in
230 if is_action "insert" then (
231 let posn = get_action "insert" in
233 model := action_insert !model posn item
234 ) else if is_action "moveup" then (
235 let posn = get_action "moveup" in
236 model := action_moveup !model posn
237 ) else if is_action "movedn" then (
238 let posn = get_action "movedn" in
239 model := action_movedn !model posn
240 ) else if is_action "delete" then (
241 let posn = get_action "delete" in
242 model := action_delete !model posn
245 model_to_template !model template
248 (* Try to save the page. Returns a boolean indicating if the
249 * page was saved successfully.
252 let model = build_internal_model () in
253 let no_errors = [] = check_for_errors model in
255 (* No errors, so we can save the page ... *)
257 let sth = dbh#prepare_cached "delete from sitemenu where hostid = ?" in
258 sth#execute [`Int hostid];
260 let sth = dbh#prepare_cached "insert into sitemenu (hostid, label, url,
261 ordering) values (?, ?, ?, ?)" in
263 List.iteri (fun i (label, url) ->
264 let ordering = 10 * (i+1) in
265 sth#execute [`Int hostid; `String label; `String url;
266 `Int ordering]) model;
268 (* Commit changes to the database. *)
271 (* Email notification, if anyone is listed for this host. *)
272 let subject = "The site menu has been edited" in
274 let body = fun () -> "Site: http://" ^ hostname ^ "/\n\n" in
276 email_notify ~body ~subject ~user dbh hostid;
278 let buttons = [ ok_button "/_bin/host_menu.cmo" ] in
279 ok ~title:"Saved" ~buttons
280 q "The site menu was saved."
287 q#redirect ("http://" ^ hostname ^ "/_bin/host_menu.cmo")
290 (* This codes decides where we are in the current editing cycle.
293 * inedit - if set, then we are in the midst of editing a page.
294 * save - if set, then we want to save the page.
295 * cancel - if set, abandon changes and go back to viewing the page.
296 * action_* - one of the action buttons was set, eg. move up/down.
297 * page - the page URL opened newly for editing.
299 if q#param_true "inedit" then (
300 if q#param_true "cancel" then (
304 if q#param_true "save" then (
305 let ok = try_save () in
306 if ok then return () (* ... else fall through *)
308 continue_editing () (* Processes the action, if any. *)
315 register_script ~restrict:[CanEdit] run