PageRenderTime 86ms CodeModel.GetById 48ms app.highlight 33ms RepoModel.GetById 2ms app.codeStats 0ms

/extra/webapps/user-admin/user-admin.factor

http://github.com/abeaumont/factor
Unknown | 167 lines | 130 code | 37 blank | 0 comment | 0 complexity | 6b3f91d78d0db68c381369f246ac1cfe MD5 | raw file
  1! Copyright (C) 2008 Slava Pestov.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: kernel sequences accessors namespaces combinators words
  4assocs db.tuples arrays splitting strings validators urls fry
  5html.forms
  6html.components
  7furnace
  8furnace.boilerplate
  9furnace.auth.providers
 10furnace.auth.providers.db
 11furnace.auth.login
 12furnace.auth
 13furnace.actions
 14furnace.redirection
 15furnace.utilities
 16http.server
 17http.server.dispatchers ;
 18IN: webapps.user-admin
 19
 20TUPLE: user-admin < dispatcher ;
 21
 22: <user-list-action> ( -- action )
 23    <page-action>
 24        [ f <user> select-tuples "users" set-value ] >>init
 25        { user-admin "user-list" } >>template ;
 26
 27: init-capabilities ( -- )
 28    capabilities get words>strings "capabilities" set-value ;
 29
 30: validate-capabilities ( -- )
 31    "capabilities" value
 32    [ [ param empty? not ] keep set-value ] each ;
 33
 34: selected-capabilities ( -- seq )
 35    "capabilities" value [ value ] filter strings>words ;
 36
 37: validate-user ( -- )
 38    {
 39        { "username" [ v-username ] }
 40        { "realname" [ [ v-one-line ] v-optional ] }
 41        { "email" [ [ v-email ] v-optional ] }
 42    } validate-params ;
 43
 44: <new-user-action> ( -- action )
 45    <page-action>
 46        [
 47            "username" param <user> from-object
 48            init-capabilities
 49        ] >>init
 50
 51        { user-admin "new-user" } >>template
 52
 53        [
 54            init-capabilities
 55            validate-capabilities
 56
 57            validate-user
 58
 59            {
 60                { "new-password" [ v-password ] }
 61                { "verify-password" [ v-password ] }
 62            } validate-params
 63
 64            same-password-twice
 65
 66            user new "username" value >>username select-tuple
 67            [ user-exists ] when
 68        ] >>validate
 69
 70        [
 71            "username" value <user>
 72                "realname" value >>realname
 73                "email" value >>email
 74                "new-password" value >>encoded-password
 75                H{ } clone >>profile
 76                selected-capabilities >>capabilities
 77
 78            insert-tuple
 79
 80            URL" $user-admin" <redirect>
 81        ] >>submit ;
 82
 83: validate-username ( -- )
 84    { { "username" [ v-username ] } } validate-params ;
 85
 86: select-capabilities ( seq -- )
 87    [ t swap word>string set-value ] each ;
 88
 89: <edit-user-action> ( -- action )
 90    <page-action>
 91        [
 92            validate-username
 93
 94            "username" value <user> select-tuple
 95            [ from-object ] [ capabilities>> select-capabilities ] bi
 96
 97            init-capabilities
 98        ] >>init
 99
100        { user-admin "edit-user" } >>template
101
102        [
103            "username" value <user> select-tuple
104            [ from-object ] [ capabilities>> select-capabilities ] bi
105
106            init-capabilities
107            validate-capabilities
108
109            validate-user
110
111            {
112                { "new-password" [ [ v-password ] v-optional ] }
113                { "verify-password" [ [ v-password ] v-optional ] }
114            } validate-params
115
116            "new-password" "verify-password"
117            [ value empty? not ] either? [
118                same-password-twice
119            ] when
120        ] >>validate
121
122        [
123            "username" value <user> select-tuple
124                "realname" value >>realname
125                "email" value >>email
126                selected-capabilities >>capabilities
127
128            "new-password" value empty? [
129                "new-password" value >>encoded-password
130            ] unless
131
132            update-tuple
133
134            URL" $user-admin" <redirect>
135        ] >>submit ;
136
137: <delete-user-action> ( -- action )
138    <action>
139        [
140            validate-username
141            "username" value <user> delete-tuples
142            URL" $user-admin" <redirect>
143        ] >>submit ;
144
145SYMBOL: can-administer-users?
146
147can-administer-users? define-capability
148
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
155    <boilerplate>
156        { user-admin "user-admin" } >>template
157    <protected>
158        "administer users" >>description
159        { can-administer-users? } >>capabilities ;
160
161: give-capability ( username capability -- )
162    [ <user> select-tuple ] dip
163    '[ _ suffix ] change-capabilities
164    update-tuple ;
165
166: make-admin ( username -- )
167    can-administer-users? give-capability ;