Working on user admin tool

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.actions http.server.auth.login http.server.db http.client
-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>

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 <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>
+    ] ;

extra/http/server/auth/admin/admin.xml

@@ -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>

extra/http/server/auth/admin/user-list.xml

@@ -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>

extra/http/server/auth/admin/user-summary.xml

@@ -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>

extra/http/server/auth/admin/user.xml

@@ -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>

extra/http/server/auth/login/edit-profile.xml

@@ -4,7 +4,7 @@
 
 	<t:title>Edit Profile</t:title>
 
-	<t:form t:action="edit-profile">
+	<t:form t:action="$login/edit-profile">
 
 	<table>
 	

extra/http/server/auth/login/login.factor

@@ -125,11 +125,11 @@ SYMBOL: user-exists?
 
                 same-password-twice
 
-                <user>
+                "username" value <user>
-                    "username" value >>username
                     "realname" value >>realname
                     "new-password" value >>password
                     "email" value >>email
+                    H{ } clone >>profile
 
                 users new-user [
                     user-exists? on

extra/http/server/auth/providers/assoc/assoc-tests.factor

@@ -6,17 +6,17 @@ namespaces accessors kernel ;
 <users-in-memory> "provider" set
 
 [ t ] [
-    <user>
+    "slava" <user>
-        "slava" >>username
         "foobar" >>password
         "slava@factorcode.org" >>email
+        H{ } clone >>profile
     "provider" get new-user
     username>> "slava" =
 ] unit-test
 
 [ f ] [
-    <user>
+    "slava" <user>
-        "slava" >>username
+        H{ } clone >>profile
     "provider" get new-user
 ] unit-test
 

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 ] [
-        <user>
+        "slava" <user>
-            "slava" >>username
             "foobar" >>password
             "slava@factorcode.org" >>email
+            H{ } clone >>profile
             "provider" get new-user
             username>> "slava" =
     ] unit-test
 
     [ f ] [
-        <user>
+        "slava" <user>
-            "slava" >>username
+            H{ } clone >>profile
         "provider" get new-user
     ] unit-test
 

extra/http/server/auth/providers/db/db.factor

@@ -20,9 +20,7 @@ user "USERS"
 SINGLETON: users-in-db
 
 : find-user ( username -- user )
-    <user>
+    <user> select-tuple ;
-        swap >>username
-    select-tuple ;
 
 M: users-in-db get-user
     drop

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> user new H{ } clone >>profile ;
+: <user> ( username -- user )
+    user new
+        swap >>username ;
 
 GENERIC: get-user ( username provider -- user/f )
 

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 ;
+
+: <inspector> ( id -- component )
+    inspector inspector-renderer new-component ;

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 <standard-redirect>
         ] >>submit ;

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 <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 ;

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 <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 ( -- )

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 <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 ;