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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Eduardo Cavazos 2008-03-14 18:20:37 -06:00
parent 7483dd7215 47e1f7edc9
commit a7d7f1c45a
17 changed files with 258 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
extra/destructors/destructors.factor
View File

@ -26,11 +26,14 @@ M: destructor dispose
: add-always-destructor ( obj -- ) : add-always-destructor ( obj -- )
<destructor> always-destructors get push ; <destructor> always-destructors get push ;
: dispose-each ( seq -- )
<reversed> [ dispose ] each ;
: do-always-destructors ( -- ) : do-always-destructors ( -- )
always-destructors get [ dispose ] each ; always-destructors get dispose-each ;
: do-error-destructors ( -- ) : do-error-destructors ( -- )
error-destructors get [ dispose ] each ; error-destructors get dispose-each ;
: with-destructors ( quot -- ) : with-destructors ( quot -- )
[ [

14
extra/hello-world/deploy.factor
View File

@ -1,14 +1,14 @@
USING: tools.deploy.config ; USING: tools.deploy.config ;
H{ H{
{ deploy-io 2 }
{ deploy-math? f }
{ deploy-threads? f }
{ deploy-compiler? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-name "Hello world (console)" } { deploy-name "Hello world (console)" }
{ deploy-reflection 2 } { deploy-threads? f }
{ deploy-c-types? f } { deploy-c-types? f }
{ deploy-compiler? f }
{ deploy-ui? f } { deploy-ui? f }
{ deploy-math? f }
{ deploy-reflection 1 }
{ deploy-word-defs? f }
{ deploy-io 2 }
{ deploy-word-props? f }
{ "stop-after-last-window?" t } { "stop-after-last-window?" t }
} }

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 ;

2
extra/sequences/lib/lib.factor
View File

@ -223,4 +223,4 @@ PRIVATE>
[ swap nth ] with map ; [ swap nth ] with map ;
: replace ( str oldseq newseq -- str' ) : replace ( str oldseq newseq -- str' )
H{ } 2seq>assoc [ dupd at* [ nip ] [ drop ] if ] curry map ; H{ } 2seq>assoc substitute ;

17
extra/sudoku/deploy.factor
View File

@ -1,13 +1,14 @@
USING: tools.deploy.config ; USING: tools.deploy.config ;
H{ H{
{ deploy-reflection 2 }
{ deploy-word-props? f }
{ deploy-compiler? t }
{ deploy-math? f }
{ deploy-c-types? f }
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-name "Sudoku" } { deploy-name "Sudoku" }
{ "stop-after-last-window?" t } { deploy-threads? f }
{ deploy-c-types? f }
{ deploy-compiler? t }
{ deploy-ui? f }
{ deploy-math? f }
{ deploy-reflection 1 }
{ deploy-word-defs? f } { deploy-word-defs? f }
{ deploy-io 2 }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
} }

12
extra/tools/deploy/backend/backend.factor
View File

@ -65,8 +65,12 @@ IN: tools.deploy.backend
: run-factor ( vm flags -- ) : run-factor ( vm flags -- )
swap add* dup . run-with-output ; inline swap add* dup . run-with-output ; inline
: make-staging-image ( vm config -- ) : make-staging-image ( config -- )
staging-command-line run-factor ; vm swap staging-command-line run-factor ;
: ?make-staging-image ( config -- )
dup [ staging-image-name ] bind exists?
[ drop ] [ make-staging-image ] if ;
: deploy-command-line ( image vocab config -- flags ) : deploy-command-line ( image vocab config -- flags )
[ [
@ -85,9 +89,7 @@ IN: tools.deploy.backend
: make-deploy-image ( vm image vocab config -- ) : make-deploy-image ( vm image vocab config -- )
make-boot-image make-boot-image
dup staging-image-name exists? [ dup ?make-staging-image
>r pick r> tuck make-staging-image
] unless
deploy-command-line run-factor ; deploy-command-line run-factor ;
SYMBOL: deploy-implementation SYMBOL: deploy-implementation

23
extra/tools/deploy/deploy-tests.factor
View File

@ -1,44 +1,47 @@
IN: tools.deploy.tests IN: tools.deploy.tests
USING: tools.test system io.files kernel tools.deploy.config USING: tools.test system io.files kernel tools.deploy.config
tools.deploy.backend math sequences io.launcher ; tools.deploy.backend math sequences io.launcher arrays ;
: shake-and-bake : shake-and-bake ( vocab -- )
"." resource-path [ "." resource-path [
vm >r vm
"test.image" temp-file "test.image" temp-file
rot dup deploy-config make-deploy-image r> dup deploy-config make-deploy-image
] with-directory ; ] with-directory ;
: small-enough? ( n -- ? )
>r "test.image" temp-file file-info file-info-size r> <= ;
[ ] [ "hello-world" shake-and-bake ] unit-test [ ] [ "hello-world" shake-and-bake ] unit-test
[ t ] [ [ t ] [
"hello.image" temp-file file-info file-info-size 500000 <= 500000 small-enough?
] unit-test ] unit-test
[ ] [ "sudoku" shake-and-bake ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test
[ t ] [ [ t ] [
"hello.image" temp-file file-info file-info-size 1500000 <= 1500000 small-enough?
] unit-test ] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test
[ t ] [ [ t ] [
"hello.image" temp-file file-info file-info-size 2000000 <= 2000000 small-enough?
] unit-test ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [ [ t ] [
"hello.image" temp-file file-info file-info-size 3000000 <= 3000000 small-enough?
] unit-test ] unit-test
[ ] [ [ ] [
"tools.deploy.test.1" shake-and-bake "tools.deploy.test.1" shake-and-bake
vm "-i=" "test.image" temp-file append try-process vm "-i=" "test.image" temp-file append 2array try-process
] unit-test ] unit-test
[ ] [ [ ] [
"tools.deploy.test.2" shake-and-bake "tools.deploy.test.2" shake-and-bake
vm "-i=" "test.image" temp-file append try-process vm "-i=" "test.image" temp-file append 2array try-process
] unit-test ] unit-test

7
extra/tools/deploy/shaker/shaker.factor
View File

@ -13,7 +13,6 @@ QUALIFIED: definitions
QUALIFIED: init QUALIFIED: init
QUALIFIED: inspector QUALIFIED: inspector
QUALIFIED: io.backend QUALIFIED: io.backend
QUALIFIED: io.nonblocking
QUALIFIED: io.thread QUALIFIED: io.thread
QUALIFIED: layouts QUALIFIED: layouts
QUALIFIED: libc.private QUALIFIED: libc.private
@ -133,8 +132,10 @@ IN: tools.deploy.shaker
strip-io? [ io.backend:io-backend , ] when strip-io? [ io.backend:io-backend , ] when
{ io.backend:io-backend io.nonblocking:default-buffer-size } [
{ "alarms" "io" "tools" } strip-vocab-globals % io.backend:io-backend
"default-buffer-size" "io.nonblocking" lookup ,
] { "alarms" "io" "tools" } strip-vocab-globals %
strip-dictionary? [ strip-dictionary? [
{ } { "cpu" } strip-vocab-globals % { } { "cpu" } strip-vocab-globals %