/dylan/group.dylan

http://github.com/cgay/wiki · Unknown · 441 lines · 385 code · 56 blank · 0 comment · 0 complexity · 9a53745cedfeeb8826512c4d5feb1758 MD5 · raw file

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