Working on user admin tool
Slava Pestov
parent
fb08017eef
commit
5f94dc3876
|
|
@ -134,8 +134,7 @@ read-response-test-1' 1array [
|
|||
|
||||
! Live-fire exercise
|
||||
USING: http.server http.server.static http.server.sessions
|
||||
http.server.sessions.storage.db http.server.actions
|
||||
http.server.auth.login http.server.db http.client
|
||||
http.server.actions http.server.auth.login http.server.db http.client
|
||||
io.server io.files io io.encodings.ascii
|
||||
accessors namespaces threads ;
|
||||
|
||||
|
|
@ -195,7 +194,6 @@ test-db [
|
|||
<action> <protected>
|
||||
<login>
|
||||
<sessions>
|
||||
sessions-in-db >>sessions
|
||||
"" add-responder
|
||||
add-quit-action
|
||||
<dispatcher>
|
||||
|
|
@ -226,7 +224,6 @@ test-db [
|
|||
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
|
||||
<login>
|
||||
<sessions>
|
||||
sessions-in-db >>sessions
|
||||
"" add-responder
|
||||
add-quit-action
|
||||
test-db <db-persistence>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,89 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors namespaces combinators
|
||||
locals db.tuples
|
||||
http.server.templating.chloe
|
||||
http.server.boilerplate
|
||||
http.server.auth.providers
|
||||
http.server.auth.providers.db
|
||||
http.server.auth.login
|
||||
http.server.forms
|
||||
http.server.components.inspector
|
||||
http.server.components
|
||||
http.server.validators
|
||||
http.server.actions
|
||||
http.server.crud
|
||||
http.server ;
|
||||
IN: http.server.auth.admin
|
||||
|
||||
: admin-template ( name -- template )
|
||||
"resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
|
||||
|
||||
: <user-form> ( -- form )
|
||||
"user" <form>
|
||||
"user" admin-template >>edit-template
|
||||
"user-summary" admin-template >>summary-template
|
||||
"username" <string> add-field
|
||||
"realname" <string> add-field
|
||||
"new-password" <password> add-field
|
||||
"verify-password" <password> add-field
|
||||
"email" <email> add-field
|
||||
"profile" <inspector> add-field ;
|
||||
|
||||
: <user-list-form> ( -- form )
|
||||
"user-list" <form>
|
||||
"user-list" admin-template >>view-template
|
||||
"list" <user-form> +plain+ <list> add-field ;
|
||||
|
||||
:: <edit-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 ]
|
||||
[ email>> "email" set-value ]
|
||||
[ profile>> "profile" set-value ]
|
||||
} cleave
|
||||
] >>init
|
||||
|
||||
[ form edit-form ] >>display
|
||||
|
||||
[
|
||||
blank-values
|
||||
|
||||
form validate-form
|
||||
|
||||
"username" value find-user
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
||||
{ "new-password" "verify-password" }
|
||||
[ value empty? ] all? [
|
||||
same-password-twice
|
||||
"new-password" value >>password
|
||||
] unless
|
||||
|
||||
update-tuple
|
||||
|
||||
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
|
||||
<boilerplate>
|
||||
"admin" admin-template >>template
|
||||
<protected>
|
||||
] ;
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:style include="resource:extra/http/server/auth/admin/admin.css" />
|
||||
|
||||
<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: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>
|
||||
|
||||
<t:form t:action="$login/logout" t:flow="begin" class="inline">
|
||||
| <button type="submit" class="link-button link">Logout</button>
|
||||
</t:form>
|
||||
</div>
|
||||
|
||||
<h1><t:write-title /></h1>
|
||||
|
||||
<t:call-next-template />
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:title>Users</t:title>
|
||||
|
||||
<t:summary t:component="list" />
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:a t:href="$user-admin/edit" t:query="username">
|
||||
<t:view t:component="username" />
|
||||
</t:a>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
<?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">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:edit 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>
|
||||
<input type="submit" value="Update" />
|
||||
|
||||
<t:if t:var="http.server.auth.login:password-mismatch?">
|
||||
<t:error>passwords do not match</t:error>
|
||||
</t:if>
|
||||
</p>
|
||||
|
||||
</t:form>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
<t:title>Edit Profile</t:title>
|
||||
|
||||
<t:form t:action="edit-profile">
|
||||
<t:form t:action="$login/edit-profile">
|
||||
|
||||
<table>
|
||||
|
||||
|
|
|
|||
|
|
@ -125,11 +125,11 @@ SYMBOL: user-exists?
|
|||
|
||||
same-password-twice
|
||||
|
||||
<user>
|
||||
"username" value >>username
|
||||
"username" value <user>
|
||||
"realname" value >>realname
|
||||
"new-password" value >>password
|
||||
"email" value >>email
|
||||
H{ } clone >>profile
|
||||
|
||||
users new-user [
|
||||
user-exists? on
|
||||
|
|
|
|||
|
|
@ -6,17 +6,17 @@ namespaces accessors kernel ;
|
|||
<users-in-memory> "provider" set
|
||||
|
||||
[ t ] [
|
||||
<user>
|
||||
"slava" >>username
|
||||
"slava" <user>
|
||||
"foobar" >>password
|
||||
"slava@factorcode.org" >>email
|
||||
H{ } clone >>profile
|
||||
"provider" get new-user
|
||||
username>> "slava" =
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
<user>
|
||||
"slava" >>username
|
||||
"slava" <user>
|
||||
H{ } clone >>profile
|
||||
"provider" get new-user
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -6,22 +6,24 @@ io.files accessors kernel ;
|
|||
|
||||
users-in-db "provider" set
|
||||
|
||||
[ "auth-test.db" temp-file delete-file ] ignore-errors
|
||||
|
||||
"auth-test.db" temp-file sqlite-db [
|
||||
|
||||
init-users-table
|
||||
|
||||
[ t ] [
|
||||
<user>
|
||||
"slava" >>username
|
||||
"slava" <user>
|
||||
"foobar" >>password
|
||||
"slava@factorcode.org" >>email
|
||||
H{ } clone >>profile
|
||||
"provider" get new-user
|
||||
username>> "slava" =
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
<user>
|
||||
"slava" >>username
|
||||
"slava" <user>
|
||||
H{ } clone >>profile
|
||||
"provider" get new-user
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -20,9 +20,7 @@ user "USERS"
|
|||
SINGLETON: users-in-db
|
||||
|
||||
: find-user ( username -- user )
|
||||
<user>
|
||||
swap >>username
|
||||
select-tuple ;
|
||||
<user> select-tuple ;
|
||||
|
||||
M: users-in-db get-user
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -6,7 +6,9 @@ IN: http.server.auth.providers
|
|||
|
||||
TUPLE: user username realname password email ticket profile ;
|
||||
|
||||
: <user> user new H{ } clone >>profile ;
|
||||
: <user> ( username -- user )
|
||||
user new
|
||||
swap >>username ;
|
||||
|
||||
GENERIC: get-user ( username provider -- user/f )
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: splitting kernel io sequences inspector accessors
|
||||
http.server.components ;
|
||||
IN: http.server.components.inspector
|
||||
|
||||
SINGLETON: inspector-renderer
|
||||
|
||||
M: inspector-renderer render-view*
|
||||
drop describe ;
|
||||
|
||||
TUPLE: inspector < component ;
|
||||
|
||||
M: inspector component-string drop ;
|
||||
|
||||
: <inspector> ( id -- component )
|
||||
inspector inspector-renderer new-component ;
|
||||
|
|
@ -51,7 +51,7 @@ IN: http.server.crud
|
|||
{ { "id" [ v-number ] } } >>post-params
|
||||
|
||||
[
|
||||
"id" get ctor call delete-tuple
|
||||
"id" get ctor call delete-tuples
|
||||
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ TUPLE: session id expires namespace changed? ;
|
|||
session "SESSIONS"
|
||||
{
|
||||
{ "id" "ID" +random-id+ system-random-generator }
|
||||
{ "expires" "EXPIRES" BIG-INTEGER +not-null+ }
|
||||
{ "expires" "EXPIRES" TIMESTAMP +not-null+ }
|
||||
{ "namespace" "NAMESPACE" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
|
|
@ -25,14 +25,13 @@ session "SESSIONS"
|
|||
|
||||
: init-sessions-table session ensure-table ;
|
||||
|
||||
: expired-sessions ( -- session )
|
||||
f <session>
|
||||
-1.0/0.0 now timestamp>millis [a,b] >>expires
|
||||
select-tuples ;
|
||||
|
||||
: start-expiring-sessions ( db seq -- )
|
||||
'[
|
||||
, , [ expired-sessions [ delete-tuple ] each ] with-db
|
||||
, , [
|
||||
session new
|
||||
-1.0/0.0 now [a,b] >>expires
|
||||
delete-tuples
|
||||
] with-db
|
||||
] 5 minutes every drop ;
|
||||
|
||||
GENERIC: init-session* ( responder -- )
|
||||
|
|
@ -72,7 +71,7 @@ TUPLE: sessions < filter-responder timeout domain ;
|
|||
session [ sessions get init-session* ] with-variable ;
|
||||
|
||||
: cutoff-time ( -- time )
|
||||
sessions get timeout>> from-now timestamp>millis ;
|
||||
sessions get timeout>> from-now ;
|
||||
|
||||
: touch-session ( session -- )
|
||||
cutoff-time >>expires drop ;
|
||||
|
|
|
|||
|
|
@ -6,9 +6,9 @@ http.server
|
|||
http.server.db
|
||||
http.server.flows
|
||||
http.server.sessions
|
||||
http.server.auth.admin
|
||||
http.server.auth.login
|
||||
http.server.auth.providers.db
|
||||
http.server.sessions.storage.db
|
||||
http.server.boilerplate
|
||||
http.server.templating.chloe
|
||||
webapps.pastebin
|
||||
|
|
@ -16,7 +16,7 @@ webapps.planet
|
|||
webapps.todo ;
|
||||
IN: webapps.factor-website
|
||||
|
||||
: test-db "test.db" resource-path sqlite-db ;
|
||||
: test-db "resource:test.db" sqlite-db ;
|
||||
|
||||
: factor-template ( path -- template )
|
||||
"resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
|
||||
|
|
@ -39,6 +39,7 @@ IN: webapps.factor-website
|
|||
<todo-list> "todo" add-responder
|
||||
<pastebin> "pastebin" add-responder
|
||||
<planet-factor> "planet" add-responder
|
||||
<user-admin> "user-admin" add-responder
|
||||
<login>
|
||||
users-in-db >>users
|
||||
allow-registration
|
||||
|
|
@ -48,7 +49,6 @@ IN: webapps.factor-website
|
|||
"page" factor-template >>template
|
||||
<flows>
|
||||
<sessions>
|
||||
sessions-in-db >>sessions
|
||||
test-db <db-persistence> ;
|
||||
|
||||
: init-factor-website ( -- )
|
||||
|
|
|
|||
|
|
@ -197,9 +197,9 @@ annotation "ANNOTATION"
|
|||
{ { "id" [ v-number ] } } >>post-params
|
||||
|
||||
[
|
||||
"id" get ctor call delete-tuple
|
||||
"id" get ctor call delete-tuples
|
||||
|
||||
"id" get f <annotation> select-tuples [ delete-tuple ] each
|
||||
"id" get f <annotation> delete-tuples
|
||||
|
||||
next f <permanent-redirect>
|
||||
] >>submit ;
|
||||
|
|
@ -209,7 +209,7 @@ annotation "ANNOTATION"
|
|||
{ { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
|
||||
|
||||
[
|
||||
"id" get "aid" get ctor call delete-tuple
|
||||
"id" get "aid" get ctor call delete-tuples
|
||||
|
||||
"id" get next <id-redirect>
|
||||
] >>submit ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue