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

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See https://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
   5 html.forms
   6 html.components
   7 furnace
   8 furnace.boilerplate
   9 furnace.auth.providers
  10 furnace.auth.providers.db
  11 furnace.auth.login
  12 furnace.auth
  13 furnace.actions
  14 furnace.redirection
  15 furnace.utilities
  16 http.server
  17 http.server.dispatchers ;
  18 IN: webapps.user-admin
  19
  20 TUPLE: 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
 145 SYMBOL: can-administer-users?
 146
 147 can-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 ;