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

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

db4
Doug Coleman 2008-03-14 20:52:53 -05:00
parent e347e3d7ac 7ae8324c38
commit 7eb54fc419
22 changed files with 259 additions and 91 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 -- )
<destructor> always-destructors get push ;
: dispose-each ( seq -- )
<reversed> [ dispose ] each ;
: do-always-destructors ( -- )
always-destructors get [ dispose ] each ;
always-destructors get dispose-each ;
: do-error-destructors ( -- )
error-destructors get [ dispose ] each ;
error-destructors get dispose-each ;
: with-destructors ( quot -- )
[

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

@ -1,14 +1,14 @@
USING: tools.deploy.config ;
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-reflection 2 }
{ deploy-threads? f }
{ deploy-c-types? f }
{ deploy-compiler? 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 }
}

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 ;

2
extra/openssl/libcrypto/libcrypto.factor
View File

@ -9,11 +9,13 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libcrypto
<<
"libcrypto" {
{ [ win32? ] [ "libeay32.dll" "stdcall" ] }
{ [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
{ [ unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
>>
C-STRUCT: bio-method
{ "int" "type" }

17
extra/sudoku/deploy.factor
View File

@ -1,13 +1,14 @@
USING: tools.deploy.config ;
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" }
{ "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-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 -- )
swap add* dup . run-with-output ; inline
: make-staging-image ( vm config -- )
staging-command-line run-factor ;
: make-staging-image ( config -- )
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 )
[
@ -85,9 +89,7 @@ IN: tools.deploy.backend
: make-deploy-image ( vm image vocab config -- )
make-boot-image
dup staging-image-name exists? [
>r pick r> tuck make-staging-image
] unless
dup ?make-staging-image
deploy-command-line run-factor ;
SYMBOL: deploy-implementation

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

@ -1,44 +1,47 @@
IN: tools.deploy.tests
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 [
vm
>r vm
"test.image" temp-file
rot dup deploy-config make-deploy-image
r> dup deploy-config make-deploy-image
] with-directory ;
: small-enough? ( n -- ? )
>r "test.image" temp-file file-info file-info-size r> <= ;
[ ] [ "hello-world" shake-and-bake ] unit-test
[ t ] [
"hello.image" temp-file file-info file-info-size 500000 <=
500000 small-enough?
] unit-test
[ ] [ "sudoku" shake-and-bake ] unit-test
[ t ] [
"hello.image" temp-file file-info file-info-size 1500000 <=
1500000 small-enough?
] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test
[ t ] [
"hello.image" temp-file file-info file-info-size 2000000 <=
2000000 small-enough?
] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [
"hello.image" temp-file file-info file-info-size 3000000 <=
3000000 small-enough?
] unit-test
[ ] [
"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
[ ] [
"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

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

@ -13,7 +13,6 @@ QUALIFIED: definitions
QUALIFIED: init
QUALIFIED: inspector
QUALIFIED: io.backend
QUALIFIED: io.nonblocking
QUALIFIED: io.thread
QUALIFIED: layouts
QUALIFIED: libc.private
@ -133,8 +132,10 @@ IN: tools.deploy.shaker
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? [
{ } { "cpu" } strip-vocab-globals %

0
extra/pdf/authors.txt → unmaintained/pdf/authors.txt
View File

0
extra/pdf/libhpdf/libhpdf.factor → unmaintained/pdf/libhpdf/libhpdf.factor
View File

0
extra/pdf/pdf-tests.factor → unmaintained/pdf/pdf-tests.factor
View File

0
extra/pdf/pdf.factor → unmaintained/pdf/pdf.factor
View File

0
extra/pdf/readme.txt → unmaintained/pdf/readme.txt
View File