/dylan/group.dylan

  1Module: %wiki
  2Synopsis: Group maintenance
  3
  4
  5// todo -- I don't like that these are mutable.  It makes it hard to
  6//         reason about the code.  Probably goes for other objects too.
  7//
  8define class <wiki-group> (<wiki-object>)
  9  slot group-owner :: <wiki-user>,
 10    required-init-keyword: owner:;
 11  constant slot group-members :: <stretchy-vector> = make(<stretchy-vector>),
 12    init-keyword: members:;
 13  slot group-description :: <string> = "",
 14    init-keyword: description:;
 15end class <wiki-group>;
 16
 17define method make
 18    (class == <wiki-group>, #rest args, #key members :: <sequence> = #[])
 19 => (group :: <wiki-group>)
 20  apply(next-method, class, members: as(<stretchy-vector>, members), args)
 21end;
 22
 23define method initialize
 24    (group :: <wiki-group>, #key)
 25  add-new!(group.group-members, group.group-owner);
 26end;
 27
 28
 29// back compat
 30define inline function group-name
 31    (group :: <wiki-group>) => (name :: <string>)
 32  group.object-name
 33end;
 34
 35// back compat
 36define inline function group-name-setter
 37    (new-name :: <string>, group :: <wiki-group>) => (new-name :: <string>)
 38  group.object-name := new-name
 39end;
 40
 41
 42// This is pretty restrictive for now.  Easier to loosen the rules later
 43// than to tighten them up.  The name has been pre-stripped and %-decoded.
 44//
 45define method validate-group-name
 46    (name :: <string>) => (name :: <string>)
 47  if (empty?(name))
 48    error("Group is required.");
 49  elseif (~regex-search(compile-regex("^[A-Za-z0-9_-]+$"), name))
 50    error("Group names may contain only alphanumerics, hyphens and underscores.");
 51  end;
 52  name
 53end method validate-group-name;
 54
 55// Must come up with a simpler, more general way to handle form errors...
 56define wf/error-test (name) in wiki end;
 57
 58
 59
 60define method permanent-link
 61    (group :: <wiki-group>)
 62 => (url :: <url>)
 63  group-permanent-link(group)
 64end;
 65
 66define method group-permanent-link
 67    (group :: <wiki-group>)
 68 => (url :: <url>)
 69  let location = wiki-url("/group/view/%s", group.group-name);
 70  transform-uris(request-url(current-request()), location, as: <url>)
 71end;
 72
 73define method redirect-to (group :: <wiki-group>)
 74  redirect-to(permanent-link(group));
 75end;
 76
 77
 78// methods
 79
 80define method find-group
 81    (name :: <string>)
 82 => (group :: false-or(<wiki-group>))
 83  element(*groups*, name, default: #f)
 84end;
 85
 86/* unused
 87define method group-exists?
 88    (name :: <string>) => (exists? :: <boolean>)
 89  find-group(name) & #t
 90end;
 91*/
 92
 93// Find all groups that a user is a member of.
 94//
 95define method user-groups
 96    (user :: <wiki-user>)
 97 => (groups :: <collection>)
 98  choose(method (group)
 99           member?(user, group.group-members)
100         end,
101         value-sequence(*groups*))
102end;
103
104define method groups-owned-by-user
105    (user :: <wiki-user>)
106 => (groups :: <collection>)
107  choose(method (group)
108           group.group-owner = user
109         end,
110         value-sequence(*groups*))
111end;
112
113define method rename-group
114    (name :: <string>, new-name :: <string>,
115     #key comment :: <string> = "")
116 => ()
117  let group = find-group(name);
118  if (group)
119    rename-group(group, new-name, comment: comment)
120  end if;
121end;
122
123define method rename-group
124    (group :: <wiki-group>, new-name :: <string>,
125     #key comment :: <string> = "")
126 => ()
127  let old-lc-name = as-lowercase(group.group-name);
128  let new-lc-name = as-lowercase(new-name);
129  if (old-lc-name ~= new-lc-name)
130    if (find-group(new-lc-name))
131      // TODO: raise more specific error...test...
132      // TODO: handle case-change-only rename.
133      error("group %s already exists", new-name);
134    end;
135    let comment = concatenate("was: ", group.group-name, ". ", comment);
136    with-lock ($group-lock)
137      remove-key!(*groups*, old-lc-name);
138      group.group-name := new-name;
139      *groups*[new-lc-name] := group;
140    end;
141    store(*storage*, group, authenticated-user(), comment,
142          standard-meta-data(group, "rename"));
143  end if;
144end method rename-group;
145
146define method create-group
147    (name :: <string>, #key comment :: <string> = "")
148 => (group :: <wiki-group>)
149  let author = authenticated-user();
150  let group = make(<wiki-group>,
151                   name: name,
152                   owner: author);
153  store(*storage*, group, author, comment, standard-meta-data(group, "create"));
154  with-lock ($group-lock)
155    *groups*[name] := group;
156  end;
157  group
158end method create-group;
159
160define method add-member
161    (user :: <wiki-user>, group :: <wiki-group>,
162     #key comment :: <string> = "")
163 => ()
164  add-new!(group.group-members, user);
165  let comment = concatenate("added ", user.user-name, ". ", comment);
166  store(*storage*, group, authenticated-user(), comment,
167        standard-meta-data(group, "add-members"));
168end;
169
170define method remove-member
171    (user :: <wiki-user>, group :: <wiki-group>,
172     #key comment :: <string> = "")
173 => ()
174  remove!(group.group-members, user);
175  let comment = concatenate("removed ", user.user-name, ". ", comment);
176  store(*storage*, group, authenticated-user(), comment,
177        standard-meta-data(group, "remove-members"));
178end;
179
180define method remove-group
181    (group :: <wiki-group>, comment :: <string>)
182 => ()
183  delete(*storage*, group, authenticated-user(), comment,
184         standard-meta-data(group, "delete"));
185  with-lock ($page-lock)
186    for (page in *pages*)
187      remove-rules-for-target(page.page-access-controls, group);
188    end;
189  end;
190  with-lock ($group-lock)
191    remove-key!(*groups*, group.group-name);
192  end;
193end method remove-group;
194
195
196//// List Groups (note not a subclass of <group-page>)
197
198define class <list-groups-page> (<wiki-dsp>)
199end;
200
201define method respond-to-get
202    (page :: <list-groups-page>, #key)
203  local method group-info (group)
204          let len = group.group-members.size;
205          make-table(<string-table>,
206                     "name" => group.group-name,
207                     "count" => integer-to-string(len),
208                     "s" => iff(len = 1, "", "s"),
209                     "description" => quote-html(group.group-description))
210        end;
211  set-attribute(page-context(), "all-groups",
212                map(group-info, with-lock ($group-lock)
213                                  value-sequence(*groups*)
214                                end));
215  next-method();
216end method respond-to-get;
217
218// Posting to /group/list creates a new group.
219//
220define method respond-to-post
221    (page :: <list-groups-page>, #key)
222  let user = authenticated-user();
223  let (new-name, error?) = validate-form-field("group", validate-group-name);
224  if (~error? & find-group(new-name))
225    add-field-error("group", "A group named %s already exists.", new-name);
226  end;
227  if (page-has-errors?())
228    respond-to-get(*list-groups-page*)
229  else
230    redirect-to(create-group(new-name));
231  end;
232end method respond-to-post;
233
234
235//// View Group
236
237define class <view-group-page> (<wiki-dsp>)
238end;
239
240define method respond-to-get
241    (dsp :: <view-group-page>,
242     #key name :: <string>, version :: false-or(<string>))
243  let name = percent-decode(name);
244  let group = find-group(name);
245  set-group-page-attributes(name, group);
246  if (group)
247    process-template(dsp);
248  else
249    // Should only get here via a typed-in URL.
250    respond-to-get(*non-existing-group-page*);
251  end if;
252end method respond-to-get;
253
254// Idea: Could only define a respond-to-get/post method on <wiki-dsp> and
255// have it call something like this, which could be specialized for
256// each object type, then dispatch to something like "handle-get/post".
257// I.e., have a standard way to set attributes on the page.
258//
259define function set-group-page-attributes
260    (name :: <string>, group :: false-or(<wiki-group>))
261  let pc = page-context();
262  set-attribute(pc, "group-name", name);
263  let user = authenticated-user();
264  if (user)
265    set-attribute(pc, "active-user", user.user-name);
266  end;
267  if (group)
268    set-attribute(pc, "group-owner", group.group-owner.user-name);
269    set-attribute(pc, "group-description", group.group-description);
270    set-attribute(pc, "group-members", sort(map(user-name, group.group-members)));
271  end;
272end function set-group-page-attributes;
273
274
275//// Edit Group
276
277define class <edit-group-page> (<wiki-dsp>)
278end;
279
280define method respond-to-get
281    (dsp :: <edit-group-page>,
282     #key name :: <string>,
283          revision :: false-or(<string>))  // TODO:
284  let name = strip(percent-decode(name));
285  let group = find-group(name);
286  set-group-page-attributes(name, group);
287  process-template(dsp);
288end;
289
290define method respond-to-post
291    (dsp :: <edit-group-page>,
292     #key name :: <string>,
293          revision :: false-or(<string>))  // TODO:
294  let name = strip(percent-decode(name));
295  let group = find-group(name);
296  set-group-page-attributes(name, group);
297  if (~group)
298    // foreign post?
299    respond-to-get(*non-existing-group-page*);
300  else
301    let new-name = validate-form-field("group-name", validate-group-name);
302    let owner-name = validate-form-field("group-owner", validate-user-name);
303    let new-owner = find-user(owner-name);
304    let comment = strip(get-query-value("comment") | "");
305    let description = strip(get-query-value("group-description") | "");
306    if (empty?(description))
307      add-field-error("group-description", "A description is required.");
308    end;
309    if (~new-owner)
310      add-field-error("group-owner", "User %s unknown", owner-name);
311    end;
312    if (new-name ~= name & find-group(new-name))
313      add-field-error("group-name",
314                      "A group named %s already exists.", new-name);
315    end;
316    if (page-has-errors?())
317      // redisplay page with errors
318      process-template(dsp);
319    else
320      // todo -- the rename and save should be part of a transaction.
321      if (new-name ~= name)
322        rename-group(group, new-name, comment: comment);
323        name := new-name;
324      end;
325      if (description ~= group.group-description
326            | new-owner ~= group.group-owner)
327        group.group-description := description;
328        group.group-owner := new-owner;
329        store(*storage*, group, authenticated-user(), comment,
330              standard-meta-data(group, "edit"));
331      end;
332      redirect-to(group);
333    end if;
334  end if;
335end method respond-to-post;
336
337
338//// Remove Group
339
340define class <remove-group-page> (<wiki-dsp>)
341end;
342
343define method respond-to-get
344    (dsp :: <remove-group-page>, #key name :: <string>)
345  let name = percent-decode(name);
346  let group = find-group(name);
347  set-group-page-attributes(name, group);
348  process-template(dsp);
349end;
350
351define method respond-to-post
352    (page :: <remove-group-page>, #key name :: <string>)
353  let name = percent-decode(name);
354  let group = find-group(name);
355  set-group-page-attributes(name, group);
356  if (group)
357    let author = authenticated-user();
358    if (author & (author = group.group-owner | administrator?(author)))
359      remove-group(group, get-query-value("comment") | "");
360      add-page-note("Group %s removed", name);
361    else
362      add-page-error("You do not have permission to remove this group.")
363    end;
364    // hack hack.  Should have some idea where the user wants to go via
365    // the 'redirect' parameter, or something like that.
366    respond-to-get(*list-groups-page*);
367  else
368    respond-to-get(*non-existing-group-page*);
369  end;
370end method respond-to-post;
371
372
373//// Edit Group Members
374
375// TODO: It should be possible to edit the group name, owner,
376//       and members all in one page.
377
378define class <edit-group-members-page> (<wiki-dsp>)
379end;
380
381define method respond-to-get
382    (page :: <edit-group-members-page>,
383     #key name :: <string>, must-exist :: <boolean> = #t)
384  let name = percent-decode(name);
385  let group = find-group(name);
386  set-group-page-attributes(name, group);
387  if (group)
388    with-lock ($user-lock)
389      // Note: user must be logged in.  That check is done in the template.
390      // non-members is for the add/remove members page
391      set-attribute(page-context(),
392                    "non-members",
393                    sort(map(user-name,
394                             choose(method (u)
395                                      ~member?(u, group.group-members)
396                                    end,
397                                    value-sequence(*users*)))));
398      // Add all users to the page context so they can be selected
399      // for group membership.
400      set-attribute(page-context(),
401                    "all-users",
402                    sort(key-sequence(*users*)));
403    end with-lock;
404  end if;
405  next-method();
406end method respond-to-get;
407
408define method respond-to-post
409    (page :: <edit-group-members-page>, #key name :: <string>)
410  let name = percent-decode(name);
411  let group = find-group(name);
412  if (group)
413    with-query-values (add as add?, remove as remove?, users, members, comment)
414      if (add? & users)
415        if (instance?(users, <string>))
416          users := list(users);
417        end if;
418        let users = choose(identity, map(find-user, users));
419        do(rcurry(add-member, group, comment:, comment), users);
420      elseif (remove? & members)
421        if (instance?(members, <string>))
422          members := list(members);
423        end if;
424        let members = choose(identity, map(find-user, members));
425        do(rcurry(remove-member, group, comment:, comment), members);
426      end if;
427      respond-to-get(page, name: name);
428    end;
429  else
430    respond-to-get(*non-existing-group-page*);
431  end;
432end method respond-to-post;
433
434
435define named-method can-modify-group?
436    (page :: <wiki-dsp>)
437  let user = authenticated-user();
438  user & (administrator?(user)
439            | user.user-name = get-attribute(page-context(), "active-user"));
440end;
441