From f1cadef89d747975d44a726bac3b6490718d8800 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 17:39:57 -0500 Subject: [PATCH 1/5] More deployment fixes --- extra/hello-world/deploy.factor | 14 +++++++------- extra/sudoku/deploy.factor | 17 +++++++++-------- extra/tools/deploy/backend/backend.factor | 12 +++++++----- extra/tools/deploy/deploy-tests.factor | 23 +++++++++++++---------- extra/tools/deploy/shaker/shaker.factor | 7 ++++--- 5 files changed, 40 insertions(+), 33 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 45d19cb891..2341aabc9d 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -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 } } diff --git a/extra/sudoku/deploy.factor b/extra/sudoku/deploy.factor index de60bed20b..11a06f46bc 100755 --- a/extra/sudoku/deploy.factor +++ b/extra/sudoku/deploy.factor @@ -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 } } diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 15dc32115e..60dc11257f 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -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 diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index a6e126ea9e..6d3385d0a4 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -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 diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index bddf3d76c9..edf78de479 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -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 % From 16244ab15aeed1523d72af0891055ef74ea50598 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 17:40:08 -0500 Subject: [PATCH 2/5] Run dtors in reverse order --- extra/destructors/destructors.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index b2561c7439..1b98d2ee0d 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -26,11 +26,14 @@ M: destructor dispose : add-always-destructor ( obj -- ) always-destructors get push ; +: dispose-each ( seq -- ) + [ 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 -- ) [ From d6d71aeb131160e3a643393aabd470876aae0af3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 17:40:47 -0500 Subject: [PATCH 3/5] Fixing httpd bugs --- extra/http/server/actions/actions.factor | 5 - .../http/server/auth/login/edit-profile.fhtml | 77 ++++++++++++ extra/http/server/auth/login/login.factor | 110 ++++++++++++++---- extra/http/server/auth/login/recover-3.fhtml | 2 +- extra/http/server/auth/login/register.fhtml | 2 +- .../server/auth/providers/providers.factor | 4 +- .../server/components/components-tests.factor | 13 +++ .../http/server/components/components.factor | 16 +-- .../server/validators/validators-tests.factor | 6 +- .../http/server/validators/validators.factor | 33 +++--- 10 files changed, 212 insertions(+), 56 deletions(-) create mode 100755 extra/http/server/auth/login/edit-profile.fhtml 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 ; %> + + +

Edit profile

+ +
+<% hidden-form-field %> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-view %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Current password:<% "password" component render-edit %>
If you don't want to change your current password, leave this field blank.
New password:<% "new-password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
If you are changing your password, enter it twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
+ +

+ +<% { + { [ login-failed? get ] [ "invalid password" render-error ] } + { [ password-mismatch? get ] [ "passwords do not match" render-error ] } + { [ t ] [ ] } +} cond %> + +

+ +
+ + + 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" add-field - "password" + "new-password" t >>required add-field "verify-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 - values get [ - "username" get >>username - "realname" get >>realname - "password" get >>password - "email" get >>email - ] bind + + "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 + +: ( -- form ) + "edit-profile"
+ "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template + "username" add-field + "realname" add-field + "password" add-field + "new-password" add-field + "verify-password" add-field + "email" add-field ; + +SYMBOL: previous-page + +:: ( -- action ) + [let | form [ ] | + + [ + blank-values + logged-in-user sget + dup username>> "username" set-value + dup realname>> "realname" set-value + dup email>> "email" set-value + ] >>init + + [ + "text/html" + [ 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 ] 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" t >>required add-field - "password" + "new-password" t >>required add-field "verify-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 +: show-login-page ( -- response ) + request get request-url post-login-url sset + "login" f ; + 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 - ] [ <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" add-responder ; + : allow-registration ( login -- login ) "register" add-responder ; @@ -294,6 +361,9 @@ M: login call-responder ( path responder -- response ) "recover-password" add-responder "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 ; %> Password: -<% "password" component render-edit %> +<% "new-password" component render-edit %> 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 ; %> Password: -<% "password" component render-edit %> +<% "new-password" component render-edit %> 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" + 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 ; -: ( id -- component ) text construct-delegate ; +: ( id -- component ) text ; + +M: text validate* 2drop ; + +M: text render-view* + drop write ; : render-textarea