/dylan/group.dylan
http://github.com/cgay/wiki · Unknown · 441 lines · 385 code · 56 blank · 0 comment · 0 complexity · 9a53745cedfeeb8826512c4d5feb1758 MD5 · raw file
- Module: %wiki
- Synopsis: Group maintenance
- // todo -- I don't like that these are mutable. It makes it hard to
- // reason about the code. Probably goes for other objects too.
- //
- define class <wiki-group> (<wiki-object>)
- slot group-owner :: <wiki-user>,
- required-init-keyword: owner:;
- constant slot group-members :: <stretchy-vector> = make(<stretchy-vector>),
- init-keyword: members:;
- slot group-description :: <string> = "",
- init-keyword: description:;
- end class <wiki-group>;
- define method make
- (class == <wiki-group>, #rest args, #key members :: <sequence> = #[])
- => (group :: <wiki-group>)
- apply(next-method, class, members: as(<stretchy-vector>, members), args)
- end;
- define method initialize
- (group :: <wiki-group>, #key)
- add-new!(group.group-members, group.group-owner);
- end;
- // back compat
- define inline function group-name
- (group :: <wiki-group>) => (name :: <string>)
- group.object-name
- end;
- // back compat
- define inline function group-name-setter
- (new-name :: <string>, group :: <wiki-group>) => (new-name :: <string>)
- group.object-name := new-name
- end;
- // This is pretty restrictive for now. Easier to loosen the rules later
- // than to tighten them up. The name has been pre-stripped and %-decoded.
- //
- define method validate-group-name
- (name :: <string>) => (name :: <string>)
- if (empty?(name))
- error("Group is required.");
- elseif (~regex-search(compile-regex("^[A-Za-z0-9_-]+$"), name))
- error("Group names may contain only alphanumerics, hyphens and underscores.");
- end;
- name
- end method validate-group-name;
- // Must come up with a simpler, more general way to handle form errors...
- define wf/error-test (name) in wiki end;
- define method permanent-link
- (group :: <wiki-group>)
- => (url :: <url>)
- group-permanent-link(group)
- end;
- define method group-permanent-link
- (group :: <wiki-group>)
- => (url :: <url>)
- let location = wiki-url("/group/view/%s", group.group-name);
- transform-uris(request-url(current-request()), location, as: <url>)
- end;
- define method redirect-to (group :: <wiki-group>)
- redirect-to(permanent-link(group));
- end;
- // methods
- define method find-group
- (name :: <string>)
- => (group :: false-or(<wiki-group>))
- element(*groups*, name, default: #f)
- end;
- /* unused
- define method group-exists?
- (name :: <string>) => (exists? :: <boolean>)
- find-group(name) & #t
- end;
- */
- // Find all groups that a user is a member of.
- //
- define method user-groups
- (user :: <wiki-user>)
- => (groups :: <collection>)
- choose(method (group)
- member?(user, group.group-members)
- end,
- value-sequence(*groups*))
- end;
- define method groups-owned-by-user
- (user :: <wiki-user>)
- => (groups :: <collection>)
- choose(method (group)
- group.group-owner = user
- end,
- value-sequence(*groups*))
- end;
- define method rename-group
- (name :: <string>, new-name :: <string>,
- #key comment :: <string> = "")
- => ()
- let group = find-group(name);
- if (group)
- rename-group(group, new-name, comment: comment)
- end if;
- end;
- define method rename-group
- (group :: <wiki-group>, new-name :: <string>,
- #key comment :: <string> = "")
- => ()
- let old-lc-name = as-lowercase(group.group-name);
- let new-lc-name = as-lowercase(new-name);
- if (old-lc-name ~= new-lc-name)
- if (find-group(new-lc-name))
- // TODO: raise more specific error...test...
- // TODO: handle case-change-only rename.
- error("group %s already exists", new-name);
- end;
- let comment = concatenate("was: ", group.group-name, ". ", comment);
- with-lock ($group-lock)
- remove-key!(*groups*, old-lc-name);
- group.group-name := new-name;
- *groups*[new-lc-name] := group;
- end;
- store(*storage*, group, authenticated-user(), comment,
- standard-meta-data(group, "rename"));
- end if;
- end method rename-group;
- define method create-group
- (name :: <string>, #key comment :: <string> = "")
- => (group :: <wiki-group>)
- let author = authenticated-user();
- let group = make(<wiki-group>,
- name: name,
- owner: author);
- store(*storage*, group, author, comment, standard-meta-data(group, "create"));
- with-lock ($group-lock)
- *groups*[name] := group;
- end;
- group
- end method create-group;
- define method add-member
- (user :: <wiki-user>, group :: <wiki-group>,
- #key comment :: <string> = "")
- => ()
- add-new!(group.group-members, user);
- let comment = concatenate("added ", user.user-name, ". ", comment);
- store(*storage*, group, authenticated-user(), comment,
- standard-meta-data(group, "add-members"));
- end;
- define method remove-member
- (user :: <wiki-user>, group :: <wiki-group>,
- #key comment :: <string> = "")
- => ()
- remove!(group.group-members, user);
- let comment = concatenate("removed ", user.user-name, ". ", comment);
- store(*storage*, group, authenticated-user(), comment,
- standard-meta-data(group, "remove-members"));
- end;
- define method remove-group
- (group :: <wiki-group>, comment :: <string>)
- => ()
- delete(*storage*, group, authenticated-user(), comment,
- standard-meta-data(group, "delete"));
- with-lock ($page-lock)
- for (page in *pages*)
- remove-rules-for-target(page.page-access-controls, group);
- end;
- end;
- with-lock ($group-lock)
- remove-key!(*groups*, group.group-name);
- end;
- end method remove-group;
- //// List Groups (note not a subclass of <group-page>)
- define class <list-groups-page> (<wiki-dsp>)
- end;
- define method respond-to-get
- (page :: <list-groups-page>, #key)
- local method group-info (group)
- let len = group.group-members.size;
- make-table(<string-table>,
- "name" => group.group-name,
- "count" => integer-to-string(len),
- "s" => iff(len = 1, "", "s"),
- "description" => quote-html(group.group-description))
- end;
- set-attribute(page-context(), "all-groups",
- map(group-info, with-lock ($group-lock)
- value-sequence(*groups*)
- end));
- next-method();
- end method respond-to-get;
- // Posting to /group/list creates a new group.
- //
- define method respond-to-post
- (page :: <list-groups-page>, #key)
- let user = authenticated-user();
- let (new-name, error?) = validate-form-field("group", validate-group-name);
- if (~error? & find-group(new-name))
- add-field-error("group", "A group named %s already exists.", new-name);
- end;
- if (page-has-errors?())
- respond-to-get(*list-groups-page*)
- else
- redirect-to(create-group(new-name));
- end;
- end method respond-to-post;
- //// View Group
- define class <view-group-page> (<wiki-dsp>)
- end;
- define method respond-to-get
- (dsp :: <view-group-page>,
- #key name :: <string>, version :: false-or(<string>))
- let name = percent-decode(name);
- let group = find-group(name);
- set-group-page-attributes(name, group);
- if (group)
- process-template(dsp);
- else
- // Should only get here via a typed-in URL.
- respond-to-get(*non-existing-group-page*);
- end if;
- end method respond-to-get;
- // Idea: Could only define a respond-to-get/post method on <wiki-dsp> and
- // have it call something like this, which could be specialized for
- // each object type, then dispatch to something like "handle-get/post".
- // I.e., have a standard way to set attributes on the page.
- //
- define function set-group-page-attributes
- (name :: <string>, group :: false-or(<wiki-group>))
- let pc = page-context();
- set-attribute(pc, "group-name", name);
- let user = authenticated-user();
- if (user)
- set-attribute(pc, "active-user", user.user-name);
- end;
- if (group)
- set-attribute(pc, "group-owner", group.group-owner.user-name);
- set-attribute(pc, "group-description", group.group-description);
- set-attribute(pc, "group-members", sort(map(user-name, group.group-members)));
- end;
- end function set-group-page-attributes;
- //// Edit Group
- define class <edit-group-page> (<wiki-dsp>)
- end;
- define method respond-to-get
- (dsp :: <edit-group-page>,
- #key name :: <string>,
- revision :: false-or(<string>)) // TODO:
- let name = strip(percent-decode(name));
- let group = find-group(name);
- set-group-page-attributes(name, group);
- process-template(dsp);
- end;
- define method respond-to-post
- (dsp :: <edit-group-page>,
- #key name :: <string>,
- revision :: false-or(<string>)) // TODO:
- let name = strip(percent-decode(name));
- let group = find-group(name);
- set-group-page-attributes(name, group);
- if (~group)
- // foreign post?
- respond-to-get(*non-existing-group-page*);
- else
- let new-name = validate-form-field("group-name", validate-group-name);
- let owner-name = validate-form-field("group-owner", validate-user-name);
- let new-owner = find-user(owner-name);
- let comment = strip(get-query-value("comment") | "");
- let description = strip(get-query-value("group-description") | "");
- if (empty?(description))
- add-field-error("group-description", "A description is required.");
- end;
- if (~new-owner)
- add-field-error("group-owner", "User %s unknown", owner-name);
- end;
- if (new-name ~= name & find-group(new-name))
- add-field-error("group-name",
- "A group named %s already exists.", new-name);
- end;
- if (page-has-errors?())
- // redisplay page with errors
- process-template(dsp);
- else
- // todo -- the rename and save should be part of a transaction.
- if (new-name ~= name)
- rename-group(group, new-name, comment: comment);
- name := new-name;
- end;
- if (description ~= group.group-description
- | new-owner ~= group.group-owner)
- group.group-description := description;
- group.group-owner := new-owner;
- store(*storage*, group, authenticated-user(), comment,
- standard-meta-data(group, "edit"));
- end;
- redirect-to(group);
- end if;
- end if;
- end method respond-to-post;
- //// Remove Group
- define class <remove-group-page> (<wiki-dsp>)
- end;
- define method respond-to-get
- (dsp :: <remove-group-page>, #key name :: <string>)
- let name = percent-decode(name);
- let group = find-group(name);
- set-group-page-attributes(name, group);
- process-template(dsp);
- end;
- define method respond-to-post
- (page :: <remove-group-page>, #key name :: <string>)
- let name = percent-decode(name);
- let group = find-group(name);
- set-group-page-attributes(name, group);
- if (group)
- let author = authenticated-user();
- if (author & (author = group.group-owner | administrator?(author)))
- remove-group(group, get-query-value("comment") | "");
- add-page-note("Group %s removed", name);
- else
- add-page-error("You do not have permission to remove this group.")
- end;
- // hack hack. Should have some idea where the user wants to go via
- // the 'redirect' parameter, or something like that.
- respond-to-get(*list-groups-page*);
- else
- respond-to-get(*non-existing-group-page*);
- end;
- end method respond-to-post;
- //// Edit Group Members
- // TODO: It should be possible to edit the group name, owner,
- // and members all in one page.
- define class <edit-group-members-page> (<wiki-dsp>)
- end;
- define method respond-to-get
- (page :: <edit-group-members-page>,
- #key name :: <string>, must-exist :: <boolean> = #t)
- let name = percent-decode(name);
- let group = find-group(name);
- set-group-page-attributes(name, group);
- if (group)
- with-lock ($user-lock)
- // Note: user must be logged in. That check is done in the template.
- // non-members is for the add/remove members page
- set-attribute(page-context(),
- "non-members",
- sort(map(user-name,
- choose(method (u)
- ~member?(u, group.group-members)
- end,
- value-sequence(*users*)))));
- // Add all users to the page context so they can be selected
- // for group membership.
- set-attribute(page-context(),
- "all-users",
- sort(key-sequence(*users*)));
- end with-lock;
- end if;
- next-method();
- end method respond-to-get;
- define method respond-to-post
- (page :: <edit-group-members-page>, #key name :: <string>)
- let name = percent-decode(name);
- let group = find-group(name);
- if (group)
- with-query-values (add as add?, remove as remove?, users, members, comment)
- if (add? & users)
- if (instance?(users, <string>))
- users := list(users);
- end if;
- let users = choose(identity, map(find-user, users));
- do(rcurry(add-member, group, comment:, comment), users);
- elseif (remove? & members)
- if (instance?(members, <string>))
- members := list(members);
- end if;
- let members = choose(identity, map(find-user, members));
- do(rcurry(remove-member, group, comment:, comment), members);
- end if;
- respond-to-get(page, name: name);
- end;
- else
- respond-to-get(*non-existing-group-page*);
- end;
- end method respond-to-post;
- define named-method can-modify-group?
- (page :: <wiki-dsp>)
- let user = authenticated-user();
- user & (administrator?(user)
- | user.user-name = get-attribute(page-context(), "active-user"));
- end;