From c3d41967f7433002dff0b9b145ee824fcc21f888 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 13 Mar 2008 02:10:43 -0500 Subject: [PATCH 01/58] fix some formatting --- extra/db/sqlite/lib/lib.factor | 15 ++++----------- extra/db/sqlite/sqlite.factor | 35 ++++++++++------------------------ 2 files changed, 14 insertions(+), 36 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index dbada854fb..d630522eb8 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -102,17 +102,10 @@ IN: db.sqlite.lib [ no-sql-type ] } case ; -: sqlite-finalize ( handle -- ) - sqlite3_finalize sqlite-check-result ; - -: sqlite-reset ( handle -- ) - sqlite3_reset sqlite-check-result ; - -: sqlite-#columns ( query -- int ) - sqlite3_column_count ; - -: sqlite-column ( handle index -- string ) - sqlite3_column_text ; +: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; +: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; +: sqlite-#columns ( query -- int ) sqlite3_column_count ; +: sqlite-column ( handle index -- string ) sqlite3_column_text ; : sqlite-column-blob ( handle index -- byte-array/f ) [ sqlite3_column_bytes ] 2keep diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index b72d788605..9a9db74401 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -17,16 +17,11 @@ M: sqlite-db db-open ( db -- ) dup sqlite-db-path sqlite-open swap set-delegate ; -M: sqlite-db db-close ( handle -- ) - sqlite-close ; - +M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; - -: with-sqlite ( path quot -- ) - sqlite-db swap with-db ; inline +: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline TUPLE: sqlite-statement ; - TUPLE: sqlite-result-set has-more? ; M: sqlite-db ( str in out -- obj ) @@ -51,8 +46,7 @@ M: sqlite-result-set dispose ( result-set -- ) : sqlite-bind ( triples handle -- ) swap [ first3 sqlite-bind-type ] with each ; -: reset-statement ( statement -- ) - statement-handle sqlite-reset ; +: reset-statement ( statement -- ) statement-handle sqlite-reset ; M: sqlite-statement bind-statement* ( statement -- ) dup statement-bound? [ dup reset-statement ] when @@ -98,14 +92,9 @@ M: sqlite-statement query-results ( query -- result-set ) dup statement-handle sqlite-result-set dup advance-row ; -M: sqlite-db begin-transaction ( -- ) - "BEGIN" sql-command ; - -M: sqlite-db commit-transaction ( -- ) - "COMMIT" sql-command ; - -M: sqlite-db rollback-transaction ( -- ) - "ROLLBACK" sql-command ; +M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; +M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ; +M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> @@ -123,9 +112,7 @@ M: sqlite-db create-sql-statement ( class -- statement ) ] sqlite-make ; M: sqlite-db drop-sql-statement ( class -- statement ) - [ - "drop table " 0% 0% ";" 0% drop - ] sqlite-make ; + [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ; M: sqlite-db ( tuple -- statement ) [ @@ -195,10 +182,9 @@ M: sqlite-db modifier-table ( -- hashtable ) { +not-null+ "not null" } } ; -M: sqlite-db compound-modifier ( str obj -- newstr ) - compound-type ; +M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; -M: sqlite-db compound-type ( str seq -- newstr ) +M: sqlite-db compound-type ( str seq -- str' ) over { { "default" [ first number>string join-space ] } [ 2drop ] ! "no sqlite compound data type" 3array throw ] @@ -219,5 +205,4 @@ M: sqlite-db type-table ( -- assoc ) { FACTOR-BLOB "blob" } } ; -M: sqlite-db create-type-table - type-table ; +M: sqlite-db create-type-table ( symbol -- str ) type-table ; From 8a2e52a10b67c7fb61241502fdceab7bff93f42b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 10:54:20 -0600 Subject: [PATCH 02/58] builder: fix bug --- extra/builder/builder.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 52150b07a8..7d95ce2409 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -134,7 +134,9 @@ SYMBOL: build-status "Did not pass load-everything: " print "load-everything-vocabs" cat "Did not pass test-all: " print "test-all-vocabs" cat - "test-all-vocabs" eval-file test-failures. + "test-failures" cat + +! "test-failures" eval-file test-failures. "help-lint results:" print "help-lint" cat From 080628af9ff52d6ca01fff09900310d4c26d37c2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 10:54:46 -0600 Subject: [PATCH 03/58] fix ldap and openssl on unix --- extra/ldap/libldap/libldap.factor | 4 ++-- extra/openssl/libcrypto/libcrypto.factor | 4 ++-- extra/openssl/libssl/libssl.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor index ae613bd461..6db6884071 100755 --- a/extra/ldap/libldap/libldap.factor +++ b/extra/ldap/libldap/libldap.factor @@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ; IN: ldap.libldap << "libldap" { - { [ win32? ] [ "libldap.dll" "stdcall" ] } + { [ win32? ] [ "libldap.dll" "stdcall" ] } { [ macosx? ] [ "libldap.dylib" "cdecl" ] } - { [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] } + { [ unix? ] [ "libldap.so" "cdecl" ] } } cond add-library >> : LDAP_VERSION1 1 ; inline diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor index 8378a11956..7b3ad2cf9f 100755 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libcrypto "libcrypto" { - { [ win32? ] [ "libeay32.dll" "stdcall" ] } + { [ win32? ] [ "libeay32.dll" "stdcall" ] } { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] } - { [ unix? ] [ "$LD_LIBRARY_PATH/libcrypto.so" "cdecl" ] } + { [ unix? ] [ "libcrypto.so" "cdecl" ] } } cond add-library C-STRUCT: bio-method diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 8d1b3b5247..d8709cbf53 100644 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl << "libssl" { - { [ win32? ] [ "ssleay32.dll" "stdcall" ] } + { [ win32? ] [ "ssleay32.dll" "stdcall" ] } { [ macosx? ] [ "libssl.dylib" "cdecl" ] } - { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] } + { [ unix? ] [ "libssl.so" "cdecl" ] } } cond add-library >> : X509_FILETYPE_PEM 1 ; inline From d6fb777e508aad4d7785515e99c7dd3fd45c69ef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 14 Mar 2008 12:56:36 -0500 Subject: [PATCH 04/58] write a replace word and 2seq>assoc --- extra/assocs/lib/lib.factor | 5 ++++- extra/sequences/lib/lib.factor | 6 +++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 88095759e6..d2eb42a117 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,4 +1,4 @@ -USING: assocs kernel vectors sequences namespaces ; +USING: arrays assocs kernel vectors sequences namespaces ; IN: assocs.lib : >set ( seq -- hash ) @@ -35,3 +35,6 @@ IN: assocs.lib [ with each ] curry assoc-each ; inline : insert ( value variable -- ) namespace insert-at ; + +: 2seq>assoc ( keys values exemplar -- assoc ) + >r 2array flip r> assoc-like ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 050de0ae1c..fe0ee52ff4 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -3,7 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors -arrays math.parser math.private sorting strings ascii macros ; +arrays math.parser math.private sorting strings ascii macros +assocs.lib ; IN: sequences.lib : each-withn ( seq quot n -- ) nwith each ; inline @@ -220,3 +221,6 @@ PRIVATE> : nths ( indices seq -- seq' ) [ swap nth ] with map ; + +: replace ( str oldseq newseq -- str' ) + H{ } 2seq>assoc [ dupd at* [ nip ] [ drop ] if ] curry map ; From 21d52749a27149aa44fd3f7c87a62d91ab0bdaa2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 12:58:10 -0600 Subject: [PATCH 05/58] io.files: 'directory?' uses file-info --- core/io/files/files.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3ab489739b..18cdbd3791 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -94,7 +94,9 @@ SYMBOL: +unknown+ : exists? ( path -- ? ) file-modified >boolean ; -: directory? ( path -- ? ) stat 3drop ; +! : directory? ( path -- ? ) stat 3drop ; + +: directory? ( path -- ? ) file-info file-info-type +directory+ = ; ! Current working directory HOOK: cd io-backend ( path -- ) From 02758aeadbac0ebe4c93d2284cc3cab1bc80d93b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 12:59:17 -0600 Subject: [PATCH 06/58] combinators.cleave: and --- extra/combinators/cleave/cleave.factor | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index fd66536c12..049c8bf2a9 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -70,3 +70,29 @@ MACRO: spread ( seq -- ) swap [ [ r> ] swap append ] map concat append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Cleave into array +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: words quotations fry arrays.lib ; + +: >quot ( obj -- quot ) dup word? [ 1quotation ] when ; + +: >quots ( seq -- seq ) [ >quot ] map ; + +MACRO: ( seq -- ) + [ >quots ] [ length ] bi + '[ , cleave , narray ] ; + +MACRO: <2arr> ( seq -- ) + [ >quots ] [ length ] bi + '[ , 2cleave , narray ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Spread into array +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MACRO: ( seq -- ) + [ >quots ] [ length ] bi + '[ , spread , narray ] ; From 2029be73440b86b9a1b8e037cc79e4224ddc5eb4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 14 Mar 2008 16:44:40 -0500 Subject: [PATCH 07/58] better replace word --- extra/sequences/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index fe0ee52ff4..13e8eb949f 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -223,4 +223,4 @@ PRIVATE> [ swap nth ] with map ; : replace ( str oldseq newseq -- str' ) - H{ } 2seq>assoc [ dupd at* [ nip ] [ drop ] if ] curry map ; + H{ } 2seq>assoc substitute ; From f1cadef89d747975d44a726bac3b6490718d8800 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 17:39:57 -0500 Subject: [PATCH 08/58] 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 09/58] 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 10/58] 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