1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel sequences accessors namespaces combinators words
4 assocs db.tuples arrays splitting strings validators urls fry
10 furnace.auth.providers.db
17 http.server.dispatchers ;
18 IN: webapps.user-admin
20 TUPLE: user-admin < dispatcher ;
22 : <user-list-action> ( -- action )
24 [ f <user> select-tuples "users" set-value ] >>init
25 { user-admin "user-list" } >>template ;
27 : init-capabilities ( -- )
28 capabilities get words>strings "capabilities" set-value ;
30 : validate-capabilities ( -- )
32 [ [ param empty? not ] keep set-value ] each ;
34 : selected-capabilities ( -- seq )
35 "capabilities" value [ value ] filter strings>words ;
37 : validate-user ( -- )
39 { "username" [ v-username ] }
40 { "realname" [ [ v-one-line ] v-optional ] }
41 { "email" [ [ v-email ] v-optional ] }
44 : <new-user-action> ( -- action )
47 "username" param <user> from-object
51 { user-admin "new-user" } >>template
60 { "new-password" [ v-password ] }
61 { "verify-password" [ v-password ] }
66 user new "username" value >>username select-tuple
71 "username" value <user>
72 "realname" value >>realname
74 "new-password" value >>encoded-password
76 selected-capabilities >>capabilities
80 URL" $user-admin" <redirect>
83 : validate-username ( -- )
84 { { "username" [ v-username ] } } validate-params ;
86 : select-capabilities ( seq -- )
87 [ t swap word>string set-value ] each ;
89 : <edit-user-action> ( -- action )
94 "username" value <user> select-tuple
95 [ from-object ] [ capabilities>> select-capabilities ] bi
100 { user-admin "edit-user" } >>template
103 "username" value <user> select-tuple
104 [ from-object ] [ capabilities>> select-capabilities ] bi
107 validate-capabilities
112 { "new-password" [ [ v-password ] v-optional ] }
113 { "verify-password" [ [ v-password ] v-optional ] }
116 "new-password" "verify-password"
117 [ value empty? not ] either? [
123 "username" value <user> select-tuple
124 "realname" value >>realname
125 "email" value >>email
126 selected-capabilities >>capabilities
128 "new-password" value empty? [
129 "new-password" value >>encoded-password
134 URL" $user-admin" <redirect>
137 : <delete-user-action> ( -- action )
141 "username" value <user> delete-tuples
142 URL" $user-admin" <redirect>
145 SYMBOL: can-administer-users?
147 can-administer-users? define-capability
149 : <user-admin> ( -- responder )
150 user-admin new-dispatcher
151 <user-list-action> "" add-responder
152 <new-user-action> "new" add-responder
153 <edit-user-action> "edit" add-responder
154 <delete-user-action> "delete" add-responder
156 { user-admin "user-admin" } >>template
158 "administer users" >>description
159 { can-administer-users? } >>capabilities ;
161 : give-capability ( username capability -- )
162 [ <user> select-tuple ] dip
163 '[ _ suffix ] change-capabilities
166 : make-admin ( username -- )
167 can-administer-users? give-capability ;