diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index 72c2d2df8e..7bee96edce 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -17,11 +17,6 @@ TUPLE: action init display submit get-params post-params ;
[ <400> ] >>display
[ <400> ] >>submit ;
-: with-validator ( string quot -- result error? )
- '[ , @ f ] [
- dup validation-error? [ t ] [ rethrow ] if
- ] recover ; inline
-
: validate-param ( name validator assoc -- error? )
swap pick
>r >r at r> with-validator swap r> set ;
diff --git a/extra/http/server/auth/login/edit-profile.fhtml b/extra/http/server/auth/login/edit-profile.fhtml
new file mode 100755
index 0000000000..7d94ca1791
--- /dev/null
+++ b/extra/http/server/auth/login/edit-profile.fhtml
@@ -0,0 +1,77 @@
+<% USING: http.server.components http.server.auth.login
+http.server namespaces kernel combinators ; %>
+<html>
+<body>
+<h1>Edit profile</h1>
+
+<form method="POST" action="edit-profile">
+<% hidden-form-field %>
+
+<table>
+
+<tr>
+<td>User name:</td>
+<td><% "username" component render-view %></td>
+</tr>
+
+<tr>
+<td>Real name:</td>
+<td><% "realname" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>Specifying a real name is optional.</td>
+</tr>
+
+<tr>
+<td>Current password:</td>
+<td><% "password" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>If you don't want to change your current password, leave this field blank.</td>
+</tr>
+
+<tr>
+<td>New password:</td>
+<td><% "new-password" component render-edit %></td>
+</tr>
+
+<tr>
+<td>Verify:</td>
+<td><% "verify-password" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>If you are changing your password, enter it twice to ensure it is correct.</td>
+</tr>
+
+<tr>
+<td>E-mail:</td>
+<td><% "email" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+</tr>
+
+</table>
+
+<p><input type="submit" value="Update" />
+
+<% {
+ { [ login-failed? get ] [ "invalid password" render-error ] }
+ { [ password-mismatch? get ] [ "passwords do not match" render-error ] }
+ { [ t ] [ ] }
+} cond %>
+
+</p>
+
+</form>
+
+</body>
+</html>
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 9b2648158d..8842e1639e 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -13,6 +13,8 @@ QUALIFIED: smtp
TUPLE: login users ;
+: users login get users>> ;
+
SYMBOL: post-login-url
SYMBOL: login-failed?
@@ -49,7 +51,7 @@ SYMBOL: login-failed?
form validate-form
"password" value "username" value
- login get users>> check-login [
+ users check-login [
successful-login
] [
login-failed? on
@@ -67,7 +69,7 @@ SYMBOL: login-failed?
t >>required
add-field
"realname" <string> add-field
- "password" <password>
+ "new-password" <password>
t >>required
add-field
"verify-password" <password>
@@ -80,7 +82,7 @@ SYMBOL: password-mismatch?
SYMBOL: user-exists?
: same-password-twice ( -- )
- "password" value "verify-password" value = [
+ "new-password" value "verify-password" value = [
password-mismatch? on
validation-failed
] unless ;
@@ -102,14 +104,13 @@ SYMBOL: user-exists?
same-password-twice
- <user> values get [
- "username" get >>username
- "realname" get >>realname
- "password" get >>password
- "email" get >>email
- ] bind
+ <user>
+ "username" value >>username
+ "realname" value >>realname
+ "new-password" value >>password
+ "email" value >>email
- login get users>> new-user [
+ users new-user [
user-exists? on
validation-failed
] unless*
@@ -118,6 +119,64 @@ SYMBOL: user-exists?
] >>submit
] ;
+! ! ! Editing user profile
+
+: <edit-profile-form> ( -- form )
+ "edit-profile" <form>
+ "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template
+ "username" <username> add-field
+ "realname" <string> add-field
+ "password" <password> add-field
+ "new-password" <password> add-field
+ "verify-password" <password> add-field
+ "email" <email> add-field ;
+
+SYMBOL: previous-page
+
+:: <edit-profile-action> ( -- action )
+ [let | form [ <edit-profile-form> ] |
+ <action>
+ [
+ blank-values
+ logged-in-user sget
+ dup username>> "username" set-value
+ dup realname>> "realname" set-value
+ dup email>> "email" set-value
+ ] >>init
+
+ [
+ "text/html" <content>
+ [ form edit-form ] >>body
+ ] >>display
+
+ [
+ blank-values
+ uid "username" set-value
+
+ form validate-form
+
+ "password" value empty? [
+ logged-in-user sget
+ ] [
+ same-password-twice
+
+ "password" value uid users check-login
+ [ login-failed? on validation-failed ] unless
+
+ "new-password" value uid users set-password
+ [ "User deleted" throw ] unless*
+ ] if
+
+ "realname" value >>realname
+ "email" value >>email
+
+ dup users update-user
+ logged-in-user sset
+
+ previous-page sget dup [ f <permanent-redirect> ] when
+ ] >>submit
+ ] ;
+
! ! ! Password recovery
SYMBOL: lost-password-from
@@ -186,7 +245,7 @@ SYMBOL: lost-password-from
form validate-form
"email" value "username" value
- login get users>> issue-ticket [
+ users issue-ticket [
send-password-email
] when*
@@ -200,7 +259,7 @@ SYMBOL: lost-password-from
"username" <username> <hidden>
t >>required
add-field
- "password" <password>
+ "new-password" <password>
t >>required
add-field
"verify-password" <password>
@@ -239,9 +298,9 @@ SYMBOL: lost-password-from
"ticket" value
"username" value
- login get users>> claim-ticket [
- "password" value >>password
- login get users>> update-user
+ users claim-ticket [
+ "new-password" value >>password
+ users update-user
"resource:extra/http/server/auth/login/recover-4.fhtml"
serve-template
@@ -265,13 +324,18 @@ TUPLE: protected responder ;
C: <protected> protected
+: show-login-page ( -- response )
+ request get request-url post-login-url sset
+ "login" f <permanent-redirect> ;
+
M: protected call-responder ( path responder -- response )
- logged-in-user sget [ responder>> call-responder ] [
+ logged-in-user sget [
+ request get request-url previous-page sset
+ responder>> call-responder
+ ] [
2drop
- request get method>> { "GET" "HEAD" } member? [
- request get request-url post-login-url sset
- "login" f <permanent-redirect>
- ] [ <400> ] if
+ request get method>> { "GET" "HEAD" } member?
+ [ show-login-page ] [ <400> ] if
] if ;
M: login call-responder ( path responder -- response )
@@ -287,6 +351,9 @@ M: login call-responder ( path responder -- response )
! ! ! Configuration
+: allow-edit-profile ( login -- login )
+ <edit-profile-action> <protected> "edit-profile" add-responder ;
+
: allow-registration ( login -- login )
<register-action> "register" add-responder ;
@@ -294,6 +361,9 @@ M: login call-responder ( path responder -- response )
<recover-action-1> "recover-password" add-responder
<recover-action-3> "new-password" add-responder ;
+: allow-edit-profile? ( -- ? )
+ login get responders>> "edit-profile" swap key? ;
+
: allow-registration? ( -- ? )
login get responders>> "register" swap key? ;
diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml
index edd32fffe8..ca4823baab 100755
--- a/extra/http/server/auth/login/recover-3.fhtml
+++ b/extra/http/server/auth/login/recover-3.fhtml
@@ -17,7 +17,7 @@ namespaces kernel combinators ; %>
<tr>
<td>Password:</td>
-<td><% "password" component render-edit %></td>
+<td><% "new-password" component render-edit %></td>
</tr>
<tr>
diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml
index 99d1547d03..9106497def 100755
--- a/extra/http/server/auth/login/register.fhtml
+++ b/extra/http/server/auth/login/register.fhtml
@@ -26,7 +26,7 @@ http.server namespaces kernel combinators ; %>
<tr>
<td>Password:</td>
-<td><% "password" component render-edit %></td>
+<td><% "new-password" component render-edit %></td>
</tr>
<tr>
diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor
index 0aa27f870d..74620a4f5d 100755
--- a/extra/http/server/auth/providers/providers.factor
+++ b/extra/http/server/auth/providers/providers.factor
@@ -17,12 +17,12 @@ GENERIC: new-user ( user provider -- user/f )
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
-:: set-password ( password username provider -- ? )
+:: set-password ( password username provider -- user/f )
[let | user [ username provider get-user ] |
user [
user
password >>password
- provider update-user t
+ provider dup update-user
] [ f ] if
] ;
diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor
index 2a507e6416..83ae7b0118 100755
--- a/extra/http/server/components/components-tests.factor
+++ b/extra/http/server/components/components-tests.factor
@@ -86,3 +86,16 @@ TUPLE: test-tuple text number more-text ;
[ t ] [ "number" value validation-error? ] unit-test
] with-scope
+
+[
+ [ ] [
+ "n" <number>
+ 0 >>min-value
+ 10 >>max-value
+ "n" set
+ ] unit-test
+
+ [ "123" ] [
+ "123" "n" get validate value>>
+ ] unit-test
+] with-scope
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index bb0fc4b3dd..df46259c14 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -7,8 +7,6 @@ http.server.actions splitting mirrors hashtables
combinators.cleave fry continuations math ;
IN: http.server.components
-SYMBOL: validation-failed?
-
SYMBOL: components
TUPLE: component id required default ;
@@ -30,16 +28,13 @@ SYMBOL: values
: validate ( value component -- result )
'[
- , ,
+ ,
over empty? [
[ default>> [ v-default ] when* ]
[ required>> [ v-required ] when ]
bi
] [ validate* ] if
- ] [
- dup validation-error?
- [ validation-failed? on ] [ rethrow ] if
- ] recover ;
+ ] with-validator ;
: render-view ( component -- )
[ id>> value ] [ render-view* ] bi ;
@@ -215,7 +210,12 @@ M: number render-error*
! Text areas
TUPLE: text ;
-: <text> ( id -- component ) <string> text construct-delegate ;
+: <text> ( id -- component ) text <component> ;
+
+M: text validate* 2drop ;
+
+M: text render-view*
+ drop write ;
: render-textarea
<textarea
diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor
index 3ef2b6c863..d0785b0126 100755
--- a/extra/http/server/validators/validators-tests.factor
+++ b/extra/http/server/validators/validators-tests.factor
@@ -13,10 +13,10 @@ accessors ;
] unit-test
[ "slava@factorcode.o" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
[ "sla@@factorcode.o" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
[ "slava@factorcodeorg" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor
index 7eb5163d33..84f22b01f4 100755
--- a/extra/http/server/validators/validators.factor
+++ b/extra/http/server/validators/validators.factor
@@ -5,21 +5,26 @@ math.parser assocs new-slots regexp fry unicode.categories
combinators.cleave sequences ;
IN: http.server.validators
+SYMBOL: validation-failed?
+
TUPLE: validation-error value reason ;
-: validation-error ( value reason -- * )
- \ validation-error construct-boa throw ;
+C: <validation-error> validation-error
+
+: with-validator ( value quot -- result )
+ [ validation-failed? on <validation-error> ] recover ;
+ inline
: v-default ( str def -- str )
over empty? spin ? ;
: v-required ( str -- str )
- dup empty? [ "required" validation-error ] when ;
+ dup empty? [ "required" throw ] when ;
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
- validation-error
+ throw
] [
drop
] if ;
@@ -27,35 +32,31 @@ TUPLE: validation-error value reason ;
: v-max-length ( str n -- str )
over length over > [
[ "must be no more than " % # " characters" % ] "" make
- validation-error
+ throw
] [
drop
] if ;
: v-number ( str -- n )
- dup string>number [ ] [
- "must be a number" validation-error
- ] ?if ;
+ dup string>number [ ] [ "must be a number" throw ] ?if ;
: v-min-value ( x n -- x )
2dup < [
- [ "must be at least " % # ] "" make
- validation-error
+ [ "must be at least " % # ] "" make throw
] [
drop
] if ;
: v-max-value ( x n -- x )
2dup > [
- [ "must be no more than " % # ] "" make
- validation-error
+ [ "must be no more than " % # ] "" make throw
] [
drop
] if ;
: v-regexp ( str what regexp -- str )
>r over r> matches?
- [ drop ] [ "invalid " swap append validation-error ] if ;
+ [ drop ] [ "invalid " swap append throw ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
@@ -64,12 +65,12 @@ TUPLE: validation-error value reason ;
v-regexp ;
: v-captcha ( str -- str )
- dup empty? [ "must remain blank" validation-error ] unless ;
+ dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
dup "\r\n" seq-intersect empty?
- [ "must be a single line" validation-error ] unless ;
+ [ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
dup [ alpha? ] all?
- [ "must be a single word" validation-error ] unless ;
+ [ "must be a single word" throw ] unless ;