From 5f94dc38765ea8897ec76ae144d7be8939f94c95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 29 Apr 2008 21:04:06 -0500 Subject: [PATCH] Working on user admin tool --- extra/http/http-tests.factor | 5 +- extra/http/server/auth/admin/admin.factor | 89 +++++++++++++++++++ extra/http/server/auth/admin/admin.xml | 24 +++++ extra/http/server/auth/admin/user-list.xml | 9 ++ extra/http/server/auth/admin/user-summary.xml | 9 ++ extra/http/server/auth/admin/user.xml | 53 +++++++++++ extra/http/server/auth/login/edit-profile.xml | 2 +- extra/http/server/auth/login/login.factor | 4 +- .../auth/providers/assoc/assoc-tests.factor | 8 +- .../server/auth/providers/db/db-tests.factor | 10 ++- extra/http/server/auth/providers/db/db.factor | 4 +- .../server/auth/providers/providers.factor | 4 +- .../components/inspector/inspector.factor | 17 ++++ extra/http/server/crud/crud.factor | 2 +- extra/http/server/sessions/sessions.factor | 15 ++-- .../factor-website/factor-website.factor | 6 +- extra/webapps/pastebin/pastebin.factor | 6 +- 17 files changed, 233 insertions(+), 34 deletions(-) create mode 100644 extra/http/server/auth/admin/admin.factor create mode 100644 extra/http/server/auth/admin/admin.xml create mode 100644 extra/http/server/auth/admin/user-list.xml create mode 100644 extra/http/server/auth/admin/user-summary.xml create mode 100644 extra/http/server/auth/admin/user.xml create mode 100644 extra/http/server/components/inspector/inspector.factor diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 0791ce9401..39e708c879 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -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 [ - sessions-in-db >>sessions "" add-responder add-quit-action @@ -226,7 +224,6 @@ test-db [ [ "text/plain" [ "Hi" write ] >>body ] >>display - sessions-in-db >>sessions "" add-responder add-quit-action test-db diff --git a/extra/http/server/auth/admin/admin.factor b/extra/http/server/auth/admin/admin.factor new file mode 100644 index 0000000000..2b7fa2b162 --- /dev/null +++ b/extra/http/server/auth/admin/admin.factor @@ -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 ; + +: ( -- form ) + "user"
+ "user" admin-template >>edit-template + "user-summary" admin-template >>summary-template + "username" add-field + "realname" add-field + "new-password" add-field + "verify-password" add-field + "email" add-field + "profile" add-field ; + +: ( -- form ) + "user-list" + "user-list" admin-template >>view-template + "list" +plain+ add-field ; + +:: ( form ctor next -- 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 + ] >>submit ; + +TUPLE: user-admin < dispatcher ; + +:: ( -- responder ) + [let | ctor [ [ ] ] | + user-admin new-dispatcher + ctor "" add-responder + ctor "$user-admin" "edit" add-responder + + "admin" admin-template >>template + + ] ; diff --git a/extra/http/server/auth/admin/admin.xml b/extra/http/server/auth/admin/admin.xml new file mode 100644 index 0000000000..1d7a1461fd --- /dev/null +++ b/extra/http/server/auth/admin/admin.xml @@ -0,0 +1,24 @@ + + + + + + +
+ List Users + | Add User + + + | Edit Profile + + + + | + +
+ +

+ + + + diff --git a/extra/http/server/auth/admin/user-list.xml b/extra/http/server/auth/admin/user-list.xml new file mode 100644 index 0000000000..520b7f2512 --- /dev/null +++ b/extra/http/server/auth/admin/user-list.xml @@ -0,0 +1,9 @@ + + + + + Users + + + + diff --git a/extra/http/server/auth/admin/user-summary.xml b/extra/http/server/auth/admin/user-summary.xml new file mode 100644 index 0000000000..c426e7c072 --- /dev/null +++ b/extra/http/server/auth/admin/user-summary.xml @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/extra/http/server/auth/admin/user.xml b/extra/http/server/auth/admin/user.xml new file mode 100644 index 0000000000..5112178fa6 --- /dev/null +++ b/extra/http/server/auth/admin/user.xml @@ -0,0 +1,53 @@ + + + + + Edit User + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:
Real name:
New password:
Verify:
E-mail:
Profile:
+ +

+ + + + passwords do not match + +

+ + + + diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml index c19b18c947..107dbba2b8 100644 --- a/extra/http/server/auth/login/edit-profile.xml +++ b/extra/http/server/auth/login/edit-profile.xml @@ -4,7 +4,7 @@ Edit Profile - + diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 716996dc5a..34adb10cf4 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -125,11 +125,11 @@ SYMBOL: user-exists? same-password-twice - - "username" value >>username + "username" value "realname" value >>realname "new-password" value >>password "email" value >>email + H{ } clone >>profile users new-user [ user-exists? on diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index a8f17d6f5d..82a2b54b0e 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -6,17 +6,17 @@ namespaces accessors kernel ; "provider" set [ t ] [ - - "slava" >>username + "slava" "foobar" >>password "slava@factorcode.org" >>email + H{ } clone >>profile "provider" get new-user username>> "slava" = ] unit-test [ f ] [ - - "slava" >>username + "slava" + H{ } clone >>profile "provider" get new-user ] unit-test diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 6daddac304..1a5298f050 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -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 ] [ - - "slava" >>username + "slava" "foobar" >>password "slava@factorcode.org" >>email + H{ } clone >>profile "provider" get new-user username>> "slava" = ] unit-test [ f ] [ - - "slava" >>username + "slava" + H{ } clone >>profile "provider" get new-user ] unit-test diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index dba91791f6..a14ed2d00a 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -20,9 +20,7 @@ user "USERS" SINGLETON: users-in-db : find-user ( username -- user ) - - swap >>username - select-tuple ; + select-tuple ; M: users-in-db get-user drop diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index a867b2381e..0394e7a08b 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -6,7 +6,9 @@ IN: http.server.auth.providers TUPLE: user username realname password email ticket profile ; -: user new H{ } clone >>profile ; +: ( username -- user ) + user new + swap >>username ; GENERIC: get-user ( username provider -- user/f ) diff --git a/extra/http/server/components/inspector/inspector.factor b/extra/http/server/components/inspector/inspector.factor new file mode 100644 index 0000000000..25ee631a06 --- /dev/null +++ b/extra/http/server/components/inspector/inspector.factor @@ -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 ; + +: ( id -- component ) + inspector inspector-renderer new-component ; diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor index 90af25df5b..28c1b02005 100755 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -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 ] >>submit ; diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index a428fb79b9..dae9fcbe26 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -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 - -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 ; diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 4136024f03..9b3ce57d02 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -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 ; @@ -39,6 +39,7 @@ IN: webapps.factor-website "todo" add-responder "pastebin" add-responder "planet" add-responder + "user-admin" add-responder users-in-db >>users allow-registration @@ -48,7 +49,6 @@ IN: webapps.factor-website "page" factor-template >>template - sessions-in-db >>sessions test-db ; : init-factor-website ( -- ) diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 616da67eee..76e7a1464a 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -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 select-tuples [ delete-tuple ] each + "id" get f delete-tuples next f ] >>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 ] >>submit ;