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

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