More work on user admin tool

extra/http/server/auth/admin/admin.factor

@@ -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
+        "new-user" admin-template >>edit-template
-        "user-summary" admin-template >>summary-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>

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

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

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

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

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

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

extra/http/server/auth/auth.factor

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

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

@@ -35,9 +35,7 @@ TUPLE: user-saver user ;
 C: <user-saver> user-saver
 
 M: user-saver dispose
-    user-profile-changed? get [
+    user>> dup changed?>> [ users update-user ] [ drop ] if ;
-        user>> 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 [
+    uid dup [
-        save-user-after
+        users get-user
+        [ logged-in-user set ] [ save-user-after ] bi
         call-next-method
     ] [
         3drop show-login-page

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

@@ -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
+    drop <user> select-tuple ;
-    find-user ;
 
 M: users-in-db new-user
     drop
     [
-        dup username>> find-user [
+        user new
+            over username>> >>username
+        select-tuple [
             drop f
         ] [
             dup insert-tuple

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

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

extra/http/server/components/components.factor

@@ -30,8 +30,6 @@ TUPLE: hidden < field ;
 
 : hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
 
-M: hidden render-view* 2drop ;
-
 ! Component protocol
 SYMBOL: components
 

extra/http/server/sessions/sessions.factor

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

extra/webapps/pastebin/pastebin.xml

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

extra/webapps/planet/planet.xml

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

extra/webapps/todo/todo.factor

@@ -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.sessions
-http.server.forms http.server.templating.chloe
+http.server.components
-http.server.boilerplate http.server.crud http.server.auth
+http.server.components.farkup
-http.server.actions http.server.db
+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