More work on user admin tool
Slava Pestov
parent
634754d0b0
commit
5e9332b634
|
|
@ -11,6 +11,7 @@ http.server.forms
|
|||
http.server.components.inspector
|
||||
http.server.components
|
||||
http.server.validators
|
||||
http.server.sessions
|
||||
http.server.actions
|
||||
http.server.crud
|
||||
http.server ;
|
||||
|
|
@ -19,12 +20,21 @@ IN: http.server.auth.admin
|
|||
: admin-template ( name -- template )
|
||||
"resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
|
||||
|
||||
: <user-form> ( -- form )
|
||||
: <new-user-form> ( -- form )
|
||||
"user" <form>
|
||||
"user" admin-template >>edit-template
|
||||
"user-summary" admin-template >>summary-template
|
||||
"new-user" admin-template >>edit-template
|
||||
"username" <string> add-field
|
||||
"realname" <string> add-field
|
||||
"new-password" <password> t >>required add-field
|
||||
"verify-password" <password> t >>required add-field
|
||||
"email" <email> add-field ;
|
||||
|
||||
: <edit-user-form> ( -- form )
|
||||
"user" <form>
|
||||
"edit-user" admin-template >>edit-template
|
||||
"user-summary" admin-template >>summary-template
|
||||
"username" <string> hidden >>renderer add-field
|
||||
"realname" <string> add-field
|
||||
"new-password" <password> add-field
|
||||
"verify-password" <password> add-field
|
||||
"email" <email> add-field
|
||||
|
|
@ -33,19 +43,15 @@ IN: http.server.auth.admin
|
|||
: <user-list-form> ( -- form )
|
||||
"user-list" <form>
|
||||
"user-list" admin-template >>view-template
|
||||
"list" <user-form> +plain+ <list> add-field ;
|
||||
"list" <edit-user-form> +unordered+ <list> add-field ;
|
||||
|
||||
:: <edit-user-action> ( form ctor next -- action )
|
||||
:: <new-user-action> ( form ctor next -- action )
|
||||
<action>
|
||||
{ { "username" [ ] } } >>get-params
|
||||
|
||||
[
|
||||
blank-values
|
||||
|
||||
"username" get ctor call
|
||||
|
||||
"username" get [ select-tuple ] when
|
||||
|
||||
{
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
|
|
@ -61,7 +67,49 @@ IN: http.server.auth.admin
|
|||
|
||||
form validate-form
|
||||
|
||||
"username" value find-user
|
||||
same-password-twice
|
||||
|
||||
user new "username" value >>username select-tuple [
|
||||
user-exists? on
|
||||
validation-failed
|
||||
] when
|
||||
|
||||
"username" value <user>
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
"new-password" value >>password
|
||||
H{ } clone >>profile
|
||||
|
||||
insert-tuple
|
||||
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
:: <edit-user-action> ( form ctor next -- action )
|
||||
<action>
|
||||
{ { "username" [ v-required ] } } >>get-params
|
||||
|
||||
[
|
||||
blank-values
|
||||
|
||||
"username" get ctor call select-tuple
|
||||
|
||||
{
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
[ profile>> "profile" set-value ]
|
||||
} cleave
|
||||
] >>init
|
||||
|
||||
[ form edit-form ] >>display
|
||||
|
||||
[
|
||||
blank-values
|
||||
|
||||
form validate-form
|
||||
|
||||
"username" value <user> select-tuple
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
||||
|
|
@ -76,13 +124,28 @@ IN: http.server.auth.admin
|
|||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
:: <delete-user-action> ( ctor next -- action )
|
||||
<action>
|
||||
{ { "username" [ ] } } >>post-params
|
||||
|
||||
[
|
||||
"username" get
|
||||
[ <user> select-tuple 1 >>deleted update-tuple ]
|
||||
[ logout-all-sessions ]
|
||||
bi
|
||||
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
TUPLE: user-admin < dispatcher ;
|
||||
|
||||
:: <user-admin> ( -- responder )
|
||||
[let | ctor [ [ <user> ] ] |
|
||||
user-admin new-dispatcher
|
||||
<user-list-form> ctor <list-action> "" add-responder
|
||||
<user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
|
||||
<new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
|
||||
<edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
|
||||
ctor "$user-admin" <delete-user-action> "delete" add-responder
|
||||
<boilerplate>
|
||||
"admin" admin-template >>template
|
||||
<protected>
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
<div class="navbar">
|
||||
<t:a t:href="$user-admin">List Users</t:a>
|
||||
| <t:a t:href="$user-admin/edit">Add User</t:a>
|
||||
| <t:a t:href="$user-admin/new">Add User</t:a>
|
||||
|
||||
<t:if t:code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,60 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:title>Edit User</t:title>
|
||||
|
||||
<t:form t:action="$user-admin/edit">
|
||||
|
||||
<t:edit t:component="username" />
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:view t:component="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Real name:</th>
|
||||
<td><t:edit t:component="realname" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">New password:</th>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify:</th>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Profile:</th>
|
||||
<td><t:view t:component="profile" /></td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
||||
<p>
|
||||
<button type="submit" class="link-button link">Update</button>
|
||||
|
||||
<t:if t:var="http.server.auth.login:password-mismatch?">
|
||||
<t:error>passwords do not match</t:error>
|
||||
</t:if>
|
||||
</p>
|
||||
|
||||
</t:form>
|
||||
|
||||
<t:form t:action="$user-admin/delete">
|
||||
<t:edit t:component="username" />
|
||||
|
||||
<button type="submit" class="link-button link">Delete</button>
|
||||
</t:form>
|
||||
</t:chloe>
|
||||
|
|
@ -2,9 +2,9 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:title>Edit User</t:title>
|
||||
<t:title>New User</t:title>
|
||||
|
||||
<t:form t:action="$user-admin/edit">
|
||||
<t:form t:action="$user-admin/new">
|
||||
|
||||
<table>
|
||||
|
||||
|
|
@ -32,16 +32,15 @@
|
|||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Profile:</th>
|
||||
<td><t:view t:component="profile" /></td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
||||
<p>
|
||||
<input type="submit" value="Update" />
|
||||
<button type="submit" class="link-button link">Create</button>
|
||||
|
||||
<t:if t:var="http.server.auth.login:user-exists?">
|
||||
<t:error>username taken</t:error>
|
||||
</t:if>
|
||||
|
||||
<t:if t:var="http.server.auth.login:password-mismatch?">
|
||||
<t:error>passwords do not match</t:error>
|
||||
|
|
@ -49,5 +48,4 @@
|
|||
</p>
|
||||
|
||||
</t:form>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -7,7 +7,6 @@ http.server.auth.providers ;
|
|||
IN: http.server.auth
|
||||
|
||||
SYMBOL: logged-in-user
|
||||
SYMBOL: user-profile-changed?
|
||||
|
||||
GENERIC: init-user-profile ( responder -- )
|
||||
|
||||
|
|
@ -19,16 +18,18 @@ M: dispatcher init-user-profile
|
|||
M: filter-responder init-user-profile
|
||||
responder>> init-user-profile ;
|
||||
|
||||
: uid ( -- string ) logged-in-user sget username>> ;
|
||||
: profile ( -- assoc ) logged-in-user get profile>> ;
|
||||
|
||||
: profile ( -- assoc ) logged-in-user sget profile>> ;
|
||||
: user-changed ( -- )
|
||||
logged-in-user get t >>changed? drop ;
|
||||
|
||||
: uget ( key -- value )
|
||||
profile at ;
|
||||
|
||||
: uset ( value key -- )
|
||||
profile set-at user-profile-changed? on ;
|
||||
profile set-at
|
||||
user-changed ;
|
||||
|
||||
: uchange ( quot key -- )
|
||||
profile swap change-at
|
||||
user-profile-changed? on ; inline
|
||||
user-changed ; inline
|
||||
|
|
|
|||
|
|
@ -35,9 +35,7 @@ TUPLE: user-saver user ;
|
|||
C: <user-saver> user-saver
|
||||
|
||||
M: user-saver dispose
|
||||
user-profile-changed? get [
|
||||
user>> users update-user
|
||||
] [ drop ] if ;
|
||||
user>> dup changed?>> [ users update-user ] [ drop ] if ;
|
||||
|
||||
: save-user-after ( user -- )
|
||||
<user-saver> add-always-destructor ;
|
||||
|
|
@ -59,7 +57,7 @@ M: user-saver dispose
|
|||
add-field ;
|
||||
|
||||
: successful-login ( user -- response )
|
||||
logged-in-user sset
|
||||
username>> set-uid
|
||||
"$login" end-flow ;
|
||||
|
||||
:: <login-action> ( -- action )
|
||||
|
|
@ -160,7 +158,7 @@ SYMBOL: user-exists?
|
|||
[
|
||||
blank-values
|
||||
|
||||
logged-in-user sget
|
||||
logged-in-user get
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
|
|
@ -175,7 +173,7 @@ SYMBOL: user-exists?
|
|||
|
||||
form validate-form
|
||||
|
||||
logged-in-user sget
|
||||
logged-in-user get
|
||||
|
||||
{ "password" "new-password" "verify-password" }
|
||||
[ value empty? ] all? [
|
||||
|
|
@ -190,9 +188,9 @@ SYMBOL: user-exists?
|
|||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
||||
drop
|
||||
t >>changed?
|
||||
|
||||
user-profile-changed? on
|
||||
drop
|
||||
|
||||
"$login" end-flow
|
||||
] >>submit
|
||||
|
|
@ -330,7 +328,7 @@ SYMBOL: lost-password-from
|
|||
: <logout-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
f logged-in-user sset
|
||||
f set-uid
|
||||
"$login/login" end-flow
|
||||
] >>submit ;
|
||||
|
||||
|
|
@ -345,8 +343,9 @@ C: <protected> protected
|
|||
"$login/login" f <standard-redirect> ;
|
||||
|
||||
M: protected call-responder* ( path responder -- response )
|
||||
logged-in-user sget dup [
|
||||
save-user-after
|
||||
uid dup [
|
||||
users get-user
|
||||
[ logged-in-user set ] [ save-user-after ] bi
|
||||
call-next-method
|
||||
] [
|
||||
3drop show-login-page
|
||||
|
|
|
|||
|
|
@ -13,23 +13,22 @@ user "USERS"
|
|||
{ "email" "EMAIL" { VARCHAR 256 } }
|
||||
{ "ticket" "TICKET" { VARCHAR 256 } }
|
||||
{ "profile" "PROFILE" FACTOR-BLOB }
|
||||
{ "deleted" "DELETED" INTEGER +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: init-users-table user ensure-table ;
|
||||
|
||||
SINGLETON: users-in-db
|
||||
|
||||
: find-user ( username -- user )
|
||||
<user> select-tuple ;
|
||||
|
||||
M: users-in-db get-user
|
||||
drop
|
||||
find-user ;
|
||||
drop <user> select-tuple ;
|
||||
|
||||
M: users-in-db new-user
|
||||
drop
|
||||
[
|
||||
dup username>> find-user [
|
||||
user new
|
||||
over username>> >>username
|
||||
select-tuple [
|
||||
drop f
|
||||
] [
|
||||
dup insert-tuple
|
||||
|
|
|
|||
|
|
@ -4,11 +4,12 @@ USING: kernel accessors random math.parser locals
|
|||
sequences math crypto.sha2 ;
|
||||
IN: http.server.auth.providers
|
||||
|
||||
TUPLE: user username realname password email ticket profile ;
|
||||
TUPLE: user username realname password email ticket profile deleted changed? ;
|
||||
|
||||
: <user> ( username -- user )
|
||||
user new
|
||||
swap >>username ;
|
||||
swap >>username
|
||||
0 >>deleted ;
|
||||
|
||||
GENERIC: get-user ( username provider -- user/f )
|
||||
|
||||
|
|
|
|||
|
|
@ -30,8 +30,6 @@ TUPLE: hidden < field ;
|
|||
|
||||
: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
|
||||
|
||||
M: hidden render-view* 2drop ;
|
||||
|
||||
! Component protocol
|
||||
SYMBOL: components
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ db db.tuples db.types
|
|||
http http.server html.elements ;
|
||||
IN: http.server.sessions
|
||||
|
||||
TUPLE: session id expires namespace changed? ;
|
||||
TUPLE: session id expires uid namespace changed? ;
|
||||
|
||||
: <session> ( id -- session )
|
||||
session new
|
||||
|
|
@ -17,6 +17,7 @@ session "SESSIONS"
|
|||
{
|
||||
{ "id" "ID" +random-id+ system-random-generator }
|
||||
{ "expires" "EXPIRES" TIMESTAMP +not-null+ }
|
||||
{ "uid" "UID" { VARCHAR 255 } }
|
||||
{ "namespace" "NAMESPACE" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
|
|
@ -67,6 +68,12 @@ TUPLE: sessions < filter-responder timeout domain ;
|
|||
[ namespace>> swap change-at ] keep
|
||||
(session-changed) ; inline
|
||||
|
||||
: uid ( -- uid )
|
||||
session get uid>> ;
|
||||
|
||||
: set-uid ( uid -- )
|
||||
session get [ (>>uid) ] [ (session-changed) ] bi ;
|
||||
|
||||
: init-session ( session -- )
|
||||
session [ sessions get init-session* ] with-variable ;
|
||||
|
||||
|
|
@ -141,3 +148,6 @@ M: sessions call-responder* ( path responder -- response )
|
|||
sessions set
|
||||
request-session [ begin-session ] unless*
|
||||
existing-session put-session-cookie ;
|
||||
|
||||
: logout-all-sessions ( uid -- )
|
||||
session new swap >>uid delete-tuples ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
|
||||
| <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
|
||||
|
||||
<t:if t:svar="http.server.auth:logged-in-user">
|
||||
<t:if t:var="http.server.auth:logged-in-user">
|
||||
|
||||
<t:if t:code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
|
||||
| <t:a t:href="$planet-factor/admin">Admin</t:a>
|
||||
|
||||
<t:if t:svar="http.server.auth:logged-in-user">
|
||||
<t:if t:var="http.server.auth:logged-in-user">
|
||||
<t:if t:code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
||||
</t:if>
|
||||
|
|
|
|||
|
|
@ -2,10 +2,16 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel locals sequences namespaces
|
||||
db db.types db.tuples
|
||||
http.server.components http.server.components.farkup
|
||||
http.server.forms http.server.templating.chloe
|
||||
http.server.boilerplate http.server.crud http.server.auth
|
||||
http.server.actions http.server.db
|
||||
http.server.sessions
|
||||
http.server.components
|
||||
http.server.components.farkup
|
||||
http.server.forms
|
||||
http.server.templating.chloe
|
||||
http.server.boilerplate
|
||||
http.server.crud
|
||||
http.server.auth
|
||||
http.server.actions
|
||||
http.server.db
|
||||
http.server.auth.login
|
||||
http.server ;
|
||||
IN: webapps.todo
|
||||
|
|
|
|||
Loading…
Reference in New Issue