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> ] >>display
[ <400> ] >>submit ; [ <400> ] >>submit ;
: with-validator ( string quot -- result error? )
'[ , @ f ] [
dup validation-error? [ t ] [ rethrow ] if
] recover ; inline
: validate-param ( name validator assoc -- error? ) : validate-param ( name validator assoc -- error? )
swap pick swap pick
>r >r at r> with-validator swap r> set ; >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>

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

@ -13,6 +13,8 @@ QUALIFIED: smtp
TUPLE: login users ; TUPLE: login users ;
: users login get users>> ;
SYMBOL: post-login-url SYMBOL: post-login-url
SYMBOL: login-failed? SYMBOL: login-failed?
@ -49,7 +51,7 @@ SYMBOL: login-failed?
form validate-form form validate-form
"password" value "username" value "password" value "username" value
login get users>> check-login [ users check-login [
successful-login successful-login
] [ ] [
login-failed? on login-failed? on
@ -67,7 +69,7 @@ SYMBOL: login-failed?
t >>required t >>required
add-field add-field
"realname" <string> add-field "realname" <string> add-field
"password" <password> "new-password" <password>
t >>required t >>required
add-field add-field
"verify-password" <password> "verify-password" <password>
@ -80,7 +82,7 @@ SYMBOL: password-mismatch?
SYMBOL: user-exists? SYMBOL: user-exists?
: same-password-twice ( -- ) : same-password-twice ( -- )
"password" value "verify-password" value = [ "new-password" value "verify-password" value = [
password-mismatch? on password-mismatch? on
validation-failed validation-failed
] unless ; ] unless ;
@ -102,14 +104,13 @@ SYMBOL: user-exists?
same-password-twice same-password-twice
<user> values get [ <user>
"username" get >>username "username" value >>username
"realname" get >>realname "realname" value >>realname
"password" get >>password "new-password" value >>password
"email" get >>email "email" value >>email
] bind
login get users>> new-user [ users new-user [
user-exists? on user-exists? on
validation-failed validation-failed
] unless* ] unless*
@ -118,6 +119,64 @@ SYMBOL: user-exists?
] >>submit ] >>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 ! ! ! Password recovery
SYMBOL: lost-password-from SYMBOL: lost-password-from
@ -186,7 +245,7 @@ SYMBOL: lost-password-from
form validate-form form validate-form
"email" value "username" value "email" value "username" value
login get users>> issue-ticket [ users issue-ticket [
send-password-email send-password-email
] when* ] when*
@ -200,7 +259,7 @@ SYMBOL: lost-password-from
"username" <username> <hidden> "username" <username> <hidden>
t >>required t >>required
add-field add-field
"password" <password> "new-password" <password>
t >>required t >>required
add-field add-field
"verify-password" <password> "verify-password" <password>
@ -239,9 +298,9 @@ SYMBOL: lost-password-from
"ticket" value "ticket" value
"username" value "username" value
login get users>> claim-ticket [ users claim-ticket [
"password" value >>password "new-password" value >>password
login get users>> update-user users update-user
"resource:extra/http/server/auth/login/recover-4.fhtml" "resource:extra/http/server/auth/login/recover-4.fhtml"
serve-template serve-template
@ -265,13 +324,18 @@ TUPLE: protected responder ;
C: <protected> protected C: <protected> protected
M: protected call-responder ( path responder -- response ) : show-login-page ( -- response )
logged-in-user sget [ responder>> call-responder ] [
2drop
request get method>> { "GET" "HEAD" } member? [
request get request-url post-login-url sset request get request-url post-login-url sset
"login" f <permanent-redirect> "login" f <permanent-redirect> ;
] [ <400> ] if
M: protected call-responder ( path responder -- response )
logged-in-user sget [
request get request-url previous-page sset
responder>> call-responder
] [
2drop
request get method>> { "GET" "HEAD" } member?
[ show-login-page ] [ <400> ] if
] if ; ] if ;
M: login call-responder ( path responder -- response ) M: login call-responder ( path responder -- response )
@ -287,6 +351,9 @@ M: login call-responder ( path responder -- response )
! ! ! Configuration ! ! ! Configuration
: allow-edit-profile ( login -- login )
<edit-profile-action> <protected> "edit-profile" add-responder ;
: allow-registration ( login -- login ) : allow-registration ( login -- login )
<register-action> "register" add-responder ; <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-1> "recover-password" add-responder
<recover-action-3> "new-password" add-responder ; <recover-action-3> "new-password" add-responder ;
: allow-edit-profile? ( -- ? )
login get responders>> "edit-profile" swap key? ;
: allow-registration? ( -- ? ) : allow-registration? ( -- ? )
login get responders>> "register" swap key? ; 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> <tr>
<td>Password:</td> <td>Password:</td>
<td><% "password" component render-edit %></td> <td><% "new-password" component render-edit %></td>
</tr> </tr>
<tr> <tr>

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

@ -26,7 +26,7 @@ http.server namespaces kernel combinators ; %>
<tr> <tr>
<td>Password:</td> <td>Password:</td>
<td><% "password" component render-edit %></td> <td><% "new-password" component render-edit %></td>
</tr> </tr>
<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 ) : check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; 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 ] | [let | user [ username provider get-user ] |
user [ user [
user user
password >>password password >>password
provider update-user t provider dup update-user
] [ f ] if ] [ 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 [ t ] [ "number" value validation-error? ] unit-test
] with-scope ] 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 ; combinators.cleave fry continuations math ;
IN: http.server.components IN: http.server.components
SYMBOL: validation-failed?
SYMBOL: components SYMBOL: components
TUPLE: component id required default ; TUPLE: component id required default ;
@ -30,16 +28,13 @@ SYMBOL: values
: validate ( value component -- result ) : validate ( value component -- result )
'[ '[
, , ,
over empty? [ over empty? [
[ default>> [ v-default ] when* ] [ default>> [ v-default ] when* ]
[ required>> [ v-required ] when ] [ required>> [ v-required ] when ]
bi bi
] [ validate* ] if ] [ validate* ] if
] [ ] with-validator ;
dup validation-error?
[ validation-failed? on ] [ rethrow ] if
] recover ;
: render-view ( component -- ) : render-view ( component -- )
[ id>> value ] [ render-view* ] bi ; [ id>> value ] [ render-view* ] bi ;
@ -215,7 +210,12 @@ M: number render-error*
! Text areas ! Text areas
TUPLE: text ; 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 : render-textarea
<textarea <textarea

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

@ -13,10 +13,10 @@ accessors ;
] unit-test ] unit-test
[ "slava@factorcode.o" v-email ] [ "slava@factorcode.o" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with [ "invalid e-mail" = ] must-fail-with
[ "sla@@factorcode.o" v-email ] [ "sla@@factorcode.o" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with [ "invalid e-mail" = ] must-fail-with
[ "slava@factorcodeorg" v-email ] [ "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 ; combinators.cleave sequences ;
IN: http.server.validators IN: http.server.validators
SYMBOL: validation-failed?
TUPLE: validation-error value reason ; TUPLE: validation-error value reason ;
: validation-error ( value reason -- * ) C: <validation-error> validation-error
\ validation-error construct-boa throw ;
: with-validator ( value quot -- result )
[ validation-failed? on <validation-error> ] recover ;
inline
: v-default ( str def -- str ) : v-default ( str def -- str )
over empty? spin ? ; over empty? spin ? ;
: v-required ( str -- str ) : v-required ( str -- str )
dup empty? [ "required" validation-error ] when ; dup empty? [ "required" throw ] when ;
: v-min-length ( str n -- str ) : v-min-length ( str n -- str )
over length over < [ over length over < [
[ "must be at least " % # " characters" % ] "" make [ "must be at least " % # " characters" % ] "" make
validation-error throw
] [ ] [
drop drop
] if ; ] if ;
@ -27,35 +32,31 @@ TUPLE: validation-error value reason ;
: v-max-length ( str n -- str ) : v-max-length ( str n -- str )
over length over > [ over length over > [
[ "must be no more than " % # " characters" % ] "" make [ "must be no more than " % # " characters" % ] "" make
validation-error throw
] [ ] [
drop drop
] if ; ] if ;
: v-number ( str -- n ) : v-number ( str -- n )
dup string>number [ ] [ dup string>number [ ] [ "must be a number" throw ] ?if ;
"must be a number" validation-error
] ?if ;
: v-min-value ( x n -- x ) : v-min-value ( x n -- x )
2dup < [ 2dup < [
[ "must be at least " % # ] "" make [ "must be at least " % # ] "" make throw
validation-error
] [ ] [
drop drop
] if ; ] if ;
: v-max-value ( x n -- x ) : v-max-value ( x n -- x )
2dup > [ 2dup > [
[ "must be no more than " % # ] "" make [ "must be no more than " % # ] "" make throw
validation-error
] [ ] [
drop drop
] if ; ] if ;
: v-regexp ( str what regexp -- str ) : v-regexp ( str what regexp -- str )
>r over r> matches? >r over r> matches?
[ drop ] [ "invalid " swap append validation-error ] if ; [ drop ] [ "invalid " swap append throw ] if ;
: v-email ( str -- str ) : v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html #! From http://www.regular-expressions.info/email.html
@ -64,12 +65,12 @@ TUPLE: validation-error value reason ;
v-regexp ; v-regexp ;
: v-captcha ( str -- str ) : v-captcha ( str -- str )
dup empty? [ "must remain blank" validation-error ] unless ; dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str ) : v-one-line ( str -- str )
dup "\r\n" seq-intersect empty? 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 ) : v-one-word ( str -- str )
dup [ alpha? ] all? dup [ alpha? ] all?
[ "must be a single word" validation-error ] unless ; [ "must be a single word" throw ] unless ;