steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixing httpd bugs

db4
Slava Pestov 2008-03-14 17:40:47 -05:00
parent 16244ab15a
commit d6d71aeb13
10 changed files with 212 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
extra/http/server/actions/actions.factor
View File

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

77
extra/http/server/auth/login/edit-profile.fhtml Executable file
View File

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

110
extra/http/server/auth/login/login.factor
View File

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

2
extra/http/server/auth/login/recover-3.fhtml
View File

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

2
extra/http/server/auth/login/register.fhtml
View File

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

4
extra/http/server/auth/providers/providers.factor
View File

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

13
extra/http/server/components/components-tests.factor
View File

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

16
extra/http/server/components/components.factor
View File

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

6
extra/http/server/validators/validators-tests.factor
View File

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

33
extra/http/server/validators/validators.factor
View File

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