diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 81063031f9..7209b7ec4d 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -29,7 +29,9 @@ $nl { $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } -{ $subsection "errors-post-mortem" } ; +{ $subsection "errors-post-mortem" } +"When Factor encouters a critical error, it calls the following word:" +{ $subsection die } ; ARTICLE: "continuations.private" "Continuation implementation details" "A continuation is simply a tuple holding the contents of the five stacks:" diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index e2eeef6528..e347e3e3d6 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,6 +1,10 @@ IN: io.files.tests USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; +[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test +[ ] [ "blahblah" temp-file make-directory ] unit-test +[ t ] [ "blahblah" temp-file directory? ] unit-test + [ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test @@ -123,3 +127,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ ] [ "copy-tree-test" temp-file delete-tree ] unit-test [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test + +[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test + +[ ] [ "append-test" ascii dispose ] unit-test diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 8e107975bb..0babb14fa7 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -429,7 +429,14 @@ $nl { $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ; HELP: die -{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } ; +{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } +{ $notes + "The term FEP originates from the Lisp machines of old. According to the Jargon File," + $nl + { $strong "fepped out" } " /fept owt/ " { $emphasis "adj." } " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'." + $nl + { $url "http://www.jargon.net/jargonfile/f/feppedout.html" } +} ; HELP: (clone) ( obj -- newobj ) { $values { "obj" object } { "newobj" "a shallow copy" } } diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index d2eb42a117..2500940373 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,4 +1,5 @@ -USING: arrays assocs kernel vectors sequences namespaces ; +USING: arrays assocs kernel vectors sequences namespaces +random math.parser ; IN: assocs.lib : >set ( seq -- hash ) @@ -38,3 +39,10 @@ IN: assocs.lib : 2seq>assoc ( keys values exemplar -- assoc ) >r 2array flip r> assoc-like ; + +: generate-key ( assoc -- str ) + >r random-256 >hex r> + 2dup key? [ nip generate-key ] [ drop ] if ; + +: set-at-unique ( value assoc -- key ) + dup generate-key [ swap set-at ] keep ; diff --git a/extra/db/db-tests.factor b/extra/db/db-tests.factor new file mode 100755 index 0000000000..9c32f9e326 --- /dev/null +++ b/extra/db/db-tests.factor @@ -0,0 +1,5 @@ +IN: db.tests +USING: tools.test db kernel ; + +{ 1 0 } [ [ drop ] query-each ] must-infer-as +{ 1 1 } [ [ ] query-map ] must-infer-as diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 26b6cbe75c..b2042c98bd 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -119,8 +119,8 @@ M: postgresql-db bind% ( spec -- ) : postgresql-make ( class quot -- ) >r sql-props r> - [ postgresql-counter off ] swap compose - { "" { } { } } nmake ; + [ postgresql-counter off call ] { "" { } { } } nmake + ; inline : create-table-sql ( class -- statement ) [ diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 63bce0a8c3..1d356b1592 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -127,6 +127,6 @@ FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 9a9db74401..3466301390 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -98,7 +98,7 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> - { "" { } { } } nmake ; + { "" { } { } } nmake ; inline M: sqlite-db create-sql-statement ( class -- statement ) [ diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 4c47066d35..ba6441bc53 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -239,3 +239,9 @@ TUPLE: exam id name score ; ; ! [ test-ranges ] test-sqlite + +\ insert-tuple must-infer +\ update-tuple must-infer +\ delete-tuple must-infer +\ select-tuple must-infer +\ define-persistent must-infer diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 82147a2efa..d50e42c0fb 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -36,7 +36,7 @@ HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) -HOOK: db ( tuple -- tuple ) +HOOK: db ( tuple class -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 661f63ab59..0f684f782a 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -18,6 +18,7 @@ tuple-syntax namespaces ; port: 80 version: "1.1" cookies: V{ } + header: H{ } } ] [ [ diff --git a/extra/http/http.factor b/extra/http/http.factor index 4dd433f85d..421a409639 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -180,6 +180,7 @@ cookies ; request construct-empty "1.1" >>version http-port >>port + H{ } clone >>header H{ } clone >>query V{ } clone >>cookies ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 45f7ff385d..c604b8a427 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,11 +1,16 @@ IN: http.server.actions.tests -USING: http.server.actions tools.test math math.parser -multiline namespaces http io.streams.string http.server -sequences accessors ; +USING: http.server.actions http.server.validators +tools.test math math.parser multiline namespaces http +io.streams.string http.server sequences accessors ; + +[ + "a" [ v-number ] { { "a" "123" } } validate-param + [ 123 ] [ "a" get ] unit-test +] with-scope [ "a" get "b" get + ] >>display - { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params + { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params "action-1" set STRING: action-request-test-1 @@ -23,7 +28,7 @@ blah [ +path+ get "xxx" get "X" concat append ] >>submit - { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params + { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params "action-2" set STRING: action-request-test-2 diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 7bee96edce..91671392c7 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors new-slots sequences kernel assocs combinators http.server http.server.validators http hashtables namespaces -combinators.cleave fry continuations ; +combinators.cleave fry continuations locals ; IN: http.server.actions SYMBOL: +path+ @@ -17,12 +17,13 @@ TUPLE: action init display submit get-params post-params ; [ <400> ] >>display [ <400> ] >>submit ; -: validate-param ( name validator assoc -- error? ) - swap pick - >r >r at r> with-validator swap r> set ; +:: validate-param ( name validator assoc -- ) + name assoc at validator with-validator name set ; inline : action-params ( validators -- error? ) - [ params get validate-param ] { } assoc>map [ ] contains? ; + validation-failed? off + params get '[ , validate-param ] assoc-each + validation-failed? get ; : handle-get ( -- response ) action get get-params>> action-params [ <400> ] [ diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 8842e1639e..a1c99f749c 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -173,7 +173,7 @@ SYMBOL: previous-page dup users update-user logged-in-user sset - previous-page sget dup [ f ] when + previous-page sget f ] >>submit ] ; @@ -347,7 +347,7 @@ M: login call-responder ( path responder -- response ) swap >>default "login" add-responder "logout" add-responder - no >>users ; + no-users >>users ; ! ! ! Configuration diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index 12c799816d..ae4c5d051f 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -3,7 +3,7 @@ USING: http.server.auth.providers http.server.auth.providers.assoc tools.test namespaces accessors kernel ; - "provider" set + "provider" set [ t ] [ @@ -26,7 +26,7 @@ namespaces accessors kernel ; [ f ] [ "xx" "blah" "provider" get set-password ] unit-test -[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test +[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor index 8433e54fda..e8ab908406 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -4,16 +4,16 @@ IN: http.server.auth.providers.assoc USING: new-slots accessors assocs kernel http.server.auth.providers ; -TUPLE: in-memory assoc ; +TUPLE: users-in-memory assoc ; -: ( -- provider ) - H{ } clone in-memory construct-boa ; +: ( -- provider ) + H{ } clone users-in-memory construct-boa ; -M: in-memory get-user ( username provider -- user/f ) +M: users-in-memory get-user ( username provider -- user/f ) assoc>> at ; -M: in-memory update-user ( user provider -- ) 2drop ; +M: users-in-memory update-user ( user provider -- ) 2drop ; -M: in-memory new-user ( user provider -- user/f ) +M: users-in-memory new-user ( user provider -- user/f ) >r dup username>> r> assoc>> 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 247359aea4..1ee7278163 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -4,12 +4,11 @@ http.server.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations io.files accessors kernel ; -from-db "provider" set +users-in-db "provider" set "auth-test.db" temp-file sqlite-db [ - [ user drop-table ] ignore-errors - [ user create-table ] ignore-errors + init-users-table [ t ] [ @@ -32,7 +31,7 @@ from-db "provider" set [ f ] [ "xx" "blah" "provider" get set-password ] unit-test - [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test + [ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index c9e1328052..aec64d3384 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db db.tuples db.types new-slots accessors -http.server.auth.providers kernel continuations ; +http.server.auth.providers kernel continuations +singleton ; IN: http.server.auth.providers.db user "USERS" @@ -16,20 +17,18 @@ user "USERS" : init-users-table user ensure-table ; -TUPLE: from-db ; - -: from-db T{ from-db } ; +SINGLETON: users-in-db : find-user ( username -- user ) swap >>username select-tuple ; -M: from-db get-user +M: users-in-db get-user drop find-user ; -M: from-db new-user +M: users-in-db new-user drop [ dup username>> find-user [ @@ -39,5 +38,5 @@ M: from-db new-user ] if ] with-transaction ; -M: from-db update-user +M: users-in-db update-user drop update-tuple ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor index 7b8bfc627c..30f6dbd06e 100755 --- a/extra/http/server/auth/providers/null/null.factor +++ b/extra/http/server/auth/providers/null/null.factor @@ -3,14 +3,12 @@ USING: http.server.auth.providers kernel ; IN: http.server.auth.providers.null -! Named "no" because we can say no >>users +TUPLE: no-users ; -TUPLE: no ; +: no-users T{ no-users } ; -: no T{ no } ; +M: no-users get-user 2drop f ; -M: no get-user 2drop f ; +M: no-users new-user 2drop f ; -M: no new-user 2drop f ; - -M: no update-user 2drop ; +M: no-users update-user 2drop ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index 74620a4f5d..cd9cc995c7 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -22,7 +22,7 @@ GENERIC: new-user ( user provider -- user/f ) user [ user password >>password - provider dup update-user + dup provider update-user ] [ f ] if ] ; diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index ac03e0efc8..45a6ff85f8 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -4,7 +4,7 @@ USING: html http http.server io kernel math namespaces continuations calendar sequences assocs new-slots hashtables accessors arrays alarms quotations combinators -combinators.cleave fry ; +combinators.cleave fry assocs.lib ; IN: http.server.callbacks SYMBOL: responder diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 83ae7b0118..09d31202c5 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -98,4 +98,12 @@ TUPLE: test-tuple text number more-text ; [ "123" ] [ "123" "n" get validate value>> ] unit-test + + [ ] [ "n" get t >>integer drop ] unit-test + + [ 3 ] [ + "3" "n" get validate + ] unit-test ] with-scope + +[ t ] [ "wake up sheeple" dup "n" validate = ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index df46259c14..02c992651a 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -187,15 +187,16 @@ M: password render-error* render-edit* render-error ; ! Number fields -TUPLE: number min-value max-value ; +TUPLE: number min-value max-value integer ; : ( id -- component ) number ; M: number validate* [ v-number ] [ + [ integer>> [ v-integer ] when ] [ min-value>> [ v-min-value ] when* ] [ max-value>> [ v-max-value ] when* ] - bi + tri ] bi* ; M: number render-view* @@ -212,7 +213,7 @@ TUPLE: text ; : ( id -- component ) text ; -M: text validate* 2drop ; +M: text validate* drop ; M: text render-view* drop write ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 60bb5d921d..ce6a1244cb 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -108,10 +108,6 @@ TUPLE: dispatcher default responders ; : ( -- dispatcher ) 404-responder get H{ } clone dispatcher construct-boa ; -: set-main ( dispatcher name -- dispatcher ) - '[ , f ] - >>default ; - : split-path ( path -- rest first ) [ CHAR: / = ] left-trim "/" split1 swap ; @@ -124,28 +120,36 @@ TUPLE: dispatcher default responders ; M: dispatcher call-responder ( path dispatcher -- response ) over [ - 2dup find-responder call-responder [ - 2nip - ] [ - default>> [ - call-responder - ] [ - drop f - ] if* - ] if* + find-responder call-responder ] [ 2drop redirect-with-/ ] if ; +: ( class -- dispatcher ) + swap construct-delegate ; inline + +TUPLE: vhost-dispatcher default responders ; + +: ( -- dispatcher ) + 404-responder get H{ } clone vhost-dispatcher construct-boa ; + +: find-vhost ( dispatcher -- responder ) + request get host>> over responders>> at* + [ nip ] [ drop default>> ] if ; + +M: vhost-dispatcher call-responder ( path dispatcher -- response ) + find-vhost call-responder ; + +: set-main ( dispatcher name -- dispatcher ) + '[ , f ] + >>default ; + : add-responder ( dispatcher responder path -- dispatcher ) pick responders>> set-at ; : add-main-responder ( dispatcher responder path -- dispatcher ) [ add-responder ] keep set-main ; -: ( class -- dispatcher ) - swap construct-delegate ; inline - SYMBOL: main-responder main-responder global @@ -219,11 +223,3 @@ SYMBOL: exit-continuation : httpd-main ( -- ) 8888 httpd ; MAIN: httpd-main - -! Utility -: generate-key ( assoc -- str ) - >r random-256 >hex r> - 2dup key? [ nip generate-key ] [ drop ] if ; - -: set-at-unique ( value assoc -- key ) - dup generate-key [ swap set-at ] keep ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 5530b04611..a6a42f9129 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -1,6 +1,8 @@ IN: http.server.sessions.tests -USING: tools.test http.server.sessions math namespaces -kernel accessors ; +USING: tools.test http http.server.sessions +http.server.sessions.storage http.server.sessions.storage.assoc +http.server math namespaces kernel accessors prettyprint +io.streams.string splitting destructors ; [ H{ } ] [ H{ } add-session-id ] unit-test @@ -12,7 +14,16 @@ C: foo M: foo init-session* drop 0 "x" sset ; -f "123" >>id [ +M: foo call-responder + 2drop + "x" [ 1+ ] schange + "text/html" [ "x" sget pprint ] >>body ; + +[ + "123" session-id set + H{ } clone session set + session-changed? off + [ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test [ ] [ 3 "x" sset ] unit-test @@ -22,22 +33,88 @@ f "123" >>id [ [ ] [ "x" [ 1- ] schange ] unit-test [ 4 ] [ "x" sget sq ] unit-test -] with-session + + [ t ] [ session-changed? get ] unit-test +] with-scope [ t ] [ f url-sessions? ] unit-test [ t ] [ f cookie-sessions? ] unit-test [ ] [ + >>sessions "manager" set ] unit-test [ { 5 0 } ] [ [ - "manager" get new-session - dup "manager" get get-session [ 5 "a" sset ] with-session - dup "manager" get get-session [ "a" sget , ] with-session - dup "manager" get get-session [ "x" sget , ] with-session - "manager" get get-session delete-session + "manager" get begin-session drop + dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session + dup "manager" get sessions>> get-session [ "a" sget , ] with-session + dup "manager" get sessions>> get-session [ "x" sget , ] with-session + "manager" get sessions>> get-session + "manager" get sessions>> delete-session ] { } make ] unit-test + +[ ] [ + + "GET" >>method + request set + "/etc" "manager" get call-responder + response set +] unit-test + +[ 307 ] [ response get code>> ] unit-test + +[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test + +: url-responder-mock-test + [ + + "GET" >>method + "id" get session-id-key set-query-param + "/" >>path + request set + "/" "manager" get call-responder + [ write-response-body drop ] with-string-writer + ] with-destructors ; + +[ "1" ] [ url-responder-mock-test ] unit-test +[ "2" ] [ url-responder-mock-test ] unit-test +[ "3" ] [ url-responder-mock-test ] unit-test +[ "4" ] [ url-responder-mock-test ] unit-test + +[ ] [ + + >>sessions + "manager" set +] unit-test + +[ + + "GET" >>method + "/" >>path + request set + "/etc" "manager" get call-responder response set + [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test + response get +] with-destructors +response set + +[ ] [ response get cookies>> "cookies" set ] unit-test + +: cookie-responder-mock-test + [ + + "GET" >>method + "cookies" get >>cookies + "/" >>path + request set + "/" "manager" get call-responder + [ write-response-body drop ] with-string-writer + ] with-destructors ; + +[ "2" ] [ cookie-responder-mock-test ] unit-test +[ "3" ] [ cookie-responder-mock-test ] unit-test +[ "4" ] [ cookie-responder-mock-test ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 260c80914e..76f022e28c 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs calendar kernel math.parser namespaces random -boxes alarms new-slots accessors http http.server +new-slots accessors http http.server +http.server.sessions.storage http.server.sessions.storage.assoc quotations hashtables sequences fry combinators.cleave -html.elements ; +html.elements symbols continuations destructors ; IN: http.server.sessions ! ! ! ! ! ! @@ -17,56 +18,48 @@ M: dispatcher init-session* drop ; TUPLE: session-manager responder sessions ; : ( responder class -- responder' ) - >r H{ } clone session-manager construct-boa r> - construct-delegate ; inline + >r session-manager construct-boa + r> construct-delegate ; inline -TUPLE: session manager id namespace alarm ; +SYMBOLS: session session-id session-changed? ; -: ( manager -- session ) - f H{ } clone \ session construct-boa ; +: sget ( key -- value ) + session get at ; -: timeout ( -- dt ) 20 minutes ; +: sset ( value key -- ) + session get set-at + session-changed? on ; -: cancel-timeout ( session -- ) - alarm>> [ cancel-alarm ] if-box? ; +: schange ( key quot -- ) + session get swap change-at + session-changed? on ; inline -: delete-session ( session -- ) - [ cancel-timeout ] - [ dup manager>> sessions>> delete-at ] - bi ; +: sessions session-manager get sessions>> ; -: touch-session ( session -- session ) - [ cancel-timeout ] - [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ] - [ ] - tri ; +: managed-responder session-manager get responder>> ; -: session ( -- assoc ) \ session get namespace>> ; +: init-session ( managed -- session ) + H{ } clone [ session [ init-session* ] with-variable ] keep ; -: sget ( key -- value ) session at ; +: begin-session ( responder -- id session ) + [ responder>> init-session ] [ sessions>> ] bi + [ new-session ] [ drop ] 2bi ; -: sset ( value key -- ) session set-at ; +! Destructor +TUPLE: session-saver id session ; -: schange ( key quot -- ) session swap change-at ; inline +C: session-saver -: init-session ( session -- session ) - dup dup \ session [ - manager>> responder>> init-session* - ] with-variable ; +M: session-saver dispose + session-changed? get [ + [ session>> ] [ id>> ] bi + sessions update-session + ] [ drop ] if ; -: new-session ( responder -- id ) - [ init-session touch-session ] - [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ] - bi id>> ; - -: get-session ( id responder -- session/f ) - sessions>> at* [ touch-session ] when ; - -: call-responder/session ( path responder session -- response ) - \ session set responder>> call-responder ; - -: sessions ( -- manager/f ) - \ session get dup [ manager>> ] when ; +: call-responder/session ( path responder id session -- response ) + [ add-always-destructor ] + [ [ session-id set ] [ session set ] bi* ] 2bi + [ session-manager set ] [ responder>> call-responder ] bi ; TUPLE: null-sessions ; @@ -74,56 +67,64 @@ TUPLE: null-sessions ; null-sessions ; M: null-sessions call-responder ( path responder -- response ) - dup call-responder/session ; + H{ } clone f call-responder/session ; TUPLE: url-sessions ; : ( responder -- responder' ) url-sessions ; -: sess-id "factorsessid" ; +: session-id-key "factorsessid" ; -: current-session ( responder -- session ) - >r request-params sess-id swap at r> get-session ; +: current-url-session ( responder -- id/f session/f ) + [ request-params session-id-key swap at ] [ sessions>> ] bi* + [ drop ] [ get-session ] 2bi ; : add-session-id ( query -- query' ) - \ session get [ id>> sess-id associate union ] when* ; + session-id get [ session-id-key associate union ] when* ; : session-form-field ( -- ) > =value + "hidden" =type + session-id-key =id + session-id-key =name + session-id get =value input/> ; +: new-url-session ( responder -- response ) + [ f ] [ begin-session drop session-id-key associate ] bi* + ; + M: url-sessions call-responder ( path responder -- response ) [ add-session-id ] link-hook set [ session-form-field ] form-hook set - dup current-session [ + dup current-url-session dup [ call-responder/session ] [ - nip - f swap new-session sess-id associate - ] if* ; + 2drop nip new-url-session + ] if ; TUPLE: cookie-sessions ; : ( responder -- responder' ) cookie-sessions ; -: get-session-cookie ( responder -- cookie ) - request get sess-id get-cookie - [ value>> swap get-session ] [ drop f ] if* ; +: current-cookie-session ( responder -- id namespace/f ) + request get session-id-key get-cookie dup + [ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ; : ( id -- cookie ) - sess-id ; + session-id-key ; + +: call-responder/new-session ( path responder -- response ) + dup begin-session + [ call-responder/session ] + [ drop ] 2bi + put-cookie ; M: cookie-sessions call-responder ( path responder -- response ) - dup get-session-cookie [ + dup current-cookie-session dup [ call-responder/session ] [ - dup new-session - [ over get-session call-responder/session ] keep - put-cookie - ] if* ; + 2drop call-responder/new-session + ] if ; diff --git a/extra/http/server/sessions/storage/assoc/assoc.factor b/extra/http/server/sessions/storage/assoc/assoc.factor new file mode 100755 index 0000000000..1339e3c867 --- /dev/null +++ b/extra/http/server/sessions/storage/assoc/assoc.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs assocs.lib new-slots accessors +http.server.sessions.storage combinators.cleave alarms kernel +fry http.server ; +IN: http.server.sessions.storage.assoc + +TUPLE: sessions-in-memory sessions alarms ; + +: ( -- storage ) + H{ } clone H{ } clone sessions-in-memory construct-boa ; + +: cancel-session-timeout ( id storage -- ) + alarms>> at [ cancel-alarm ] when* ; + +: touch-session ( id storage -- ) + [ cancel-session-timeout ] + [ '[ , , delete-session ] timeout later ] + [ alarms>> set-at ] + 2tri ; + +M: sessions-in-memory get-session ( id storage -- namespace ) + [ sessions>> at ] [ touch-session ] 2bi ; + +M: sessions-in-memory update-session ( namespace id storage -- ) + [ sessions>> set-at ] + [ touch-session ] + 2bi ; + +M: sessions-in-memory delete-session ( id storage -- ) + [ sessions>> delete-at ] + [ cancel-session-timeout ] + 2bi ; + +M: sessions-in-memory new-session ( namespace storage -- id ) + [ sessions>> set-at-unique ] + [ [ touch-session ] [ drop ] 2bi ] + bi ; diff --git a/extra/http/server/sessions/storage/db/db-tests.factor b/extra/http/server/sessions/storage/db/db-tests.factor new file mode 100755 index 0000000000..4e6ae8a9b4 --- /dev/null +++ b/extra/http/server/sessions/storage/db/db-tests.factor @@ -0,0 +1,24 @@ +IN: http.server.sessions.storage.db +USING: http.server.sessions.storage +http.server.sessions.storage.db namespaces io.files +db.sqlite db accessors math tools.test kernel assocs +sequences ; + +sessions-in-db "storage" set + +"auth-test.db" temp-file sqlite-db [ + [ ] [ init-sessions-table ] unit-test + + [ f ] [ H{ } "storage" get new-session empty? ] unit-test + + H{ } "storage" get new-session "id" set + + "id" get "storage" get get-session "session" set + "a" "b" "session" get set-at + + "session" get "id" get "storage" get update-session + + [ H{ { "b" "a" } } ] [ + "id" get "storage" get get-session + ] unit-test +] with-db diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor new file mode 100755 index 0000000000..6ef655bde2 --- /dev/null +++ b/extra/http/server/sessions/storage/db/db.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs new-slots accessors http.server.sessions.storage +alarms kernel http.server db.tuples db.types singleton +combinators.cleave math.parser ; +IN: http.server.sessions.storage.db + +SINGLETON: sessions-in-db + +TUPLE: session id namespace ; + +session "SESSIONS" +{ + { "id" "ID" INTEGER +native-id+ } + { "namespace" "NAMESPACE" FACTOR-BLOB } +} define-persistent + +: init-sessions-table session ensure-table ; + +: ( id -- session ) + session construct-empty + swap dup [ string>number ] when >>id ; + +USING: namespaces io prettyprint ; +M: sessions-in-db get-session ( id storage -- namespace/f ) + global [ "get " write over print flush ] bind + drop + dup [ + + select-tuple dup [ namespace>> ] when global [ dup . ] bind + ] when ; + +M: sessions-in-db update-session ( namespace id storage -- ) + global [ "update " write over print flush ] bind + drop + + swap global [ dup . ] bind >>namespace + dup update-tuple + id>> select-tuple global [ . flush ] bind + ; + +M: sessions-in-db delete-session ( id storage -- ) + drop + + delete-tuple ; + +M: sessions-in-db new-session ( namespace storage -- id ) + global [ "new " print flush ] bind + drop + f + swap global [ dup . ] bind >>namespace + [ insert-tuple ] [ id>> number>string ] bi ; diff --git a/extra/http/server/sessions/storage/storage.factor b/extra/http/server/sessions/storage/storage.factor new file mode 100755 index 0000000000..df96c815c7 --- /dev/null +++ b/extra/http/server/sessions/storage/storage.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar ; +IN: http.server.sessions.storage + +: timeout 20 minutes ; + +GENERIC: get-session ( id storage -- namespace ) + +GENERIC: update-session ( namespace id storage -- ) + +GENERIC: delete-session ( id storage -- ) + +GENERIC: new-session ( namespace storage -- id ) diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor index d0785b0126..82827ac450 100755 --- a/extra/http/server/validators/validators-tests.factor +++ b/extra/http/server/validators/validators-tests.factor @@ -2,7 +2,8 @@ IN: http.server.validators.tests USING: kernel sequences tools.test http.server.validators accessors ; -[ "foo" v-number ] [ validation-error? ] must-fail-with +[ "foo" v-number ] must-fail +[ 123 ] [ "123" v-number ] unit-test [ "slava@factorcode.org" ] [ "slava@factorcode.org" v-email diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index 84f22b01f4..539a58d19f 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -40,6 +40,9 @@ C: validation-error : v-number ( str -- n ) dup string>number [ ] [ "must be a number" throw ] ?if ; +: v-integer ( n -- n ) + dup integer? [ "must be an integer" throw ] unless ; + : v-min-value ( x n -- x ) 2dup < [ [ "must be at least " % # ] "" make throw diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 2180ff7901..35aaf456a3 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -7,7 +7,7 @@ sequences namespaces words symbols ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ -+directory+ +archive+ +device+ +normal+ +temporary+ ++archive+ +device+ +normal+ +temporary+ +sparse-file+ +reparse-point+ +compressed+ +offline+ +not-content-indexed+ +encrypted+ ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index f6a9dd451f..dac55664a4 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -76,11 +76,8 @@ M: win32-file close-handle ( handle -- ) ] when drop ; : open-append ( path -- handle length ) - dup file-info file-info-size dup [ - >r (open-append) r> 2dup set-file-pointer - ] [ - drop open-write - ] if ; + [ dup file-info file-info-size ] [ drop 0 ] recover + >r (open-append) r> 2dup set-file-pointer ; TUPLE: FileArgs hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index d181ab8a16..372216c45e 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -3,8 +3,8 @@ USING: namespaces kernel io calendar sequences io.files io.sockets continuations prettyprint assocs math.parser words debugger math combinators concurrency.messaging -threads arrays init math.ranges strings calendar.format -io.encodings.ascii ; +threads arrays init math.ranges strings calendar.format +io.encodings.utf8 ; IN: logging.server : log-root ( -- string ) @@ -21,7 +21,7 @@ SYMBOL: log-files : open-log-stream ( service -- stream ) log-path dup make-directories - 1 log# ascii ; + 1 log# utf8 ; : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; diff --git a/extra/namespaces/lib/lib-tests.factor b/extra/namespaces/lib/lib-tests.factor new file mode 100755 index 0000000000..20769e161c --- /dev/null +++ b/extra/namespaces/lib/lib-tests.factor @@ -0,0 +1,6 @@ +IN: namespaces.lib.tests +USING: namespaces.lib tools.test ; + +[ ] [ [ ] { } nmake ] unit-test + +[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor old mode 100644 new mode 100755 index 76ba0ac63e..47b6b33a9a --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -2,7 +2,7 @@ ! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - assocs.lib math.parser math sequences.lib ; + assocs.lib math.parser math sequences.lib locals ; IN: namespaces.lib @@ -42,11 +42,19 @@ SYMBOL: building-seq : 4% 4 n% ; : 4# 4 n# ; -: nmake ( quot exemplars -- seqs ) - dup length dup zero? [ 1+ ] when - [ +MACRO:: nmake ( quot exemplars -- ) + [let | n [ exemplars length ] | [ - [ drop 1024 swap new-resizable ] 2map - [ building-seq set call ] keep - ] 2keep >r [ like ] 2map r> firstn - ] with-scope ; + [ + exemplars + [ 0 swap new-resizable ] map + building-seq set + + quot call + + building-seq get + exemplars [ like ] 2map + n firstn + ] with-scope + ] + ] ; diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index b19c2f39c9..6e6a924382 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -79,3 +79,6 @@ IN: sequences.lib.tests [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test [ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test + +[ ] [ { } 0 firstn ] unit-test +[ "a" ] [ { "a" } 1 firstn ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 13e8eb949f..a6b6b73148 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -4,7 +4,7 @@ USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors arrays math.parser math.private sorting strings ascii macros -assocs.lib ; +assocs.lib quotations ; IN: sequences.lib : each-withn ( seq quot n -- ) nwith each ; inline @@ -20,8 +20,9 @@ IN: sequences.lib : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline MACRO: firstn ( n -- ) - [ [ swap nth ] curry - [ keep ] curry ] map concat [ drop ] compose ; + [ [ swap nth ] curry [ keep ] curry ] map + concat >quotation + [ drop ] compose ; : prepare-index ( seq quot -- seq n quot ) >r dup length r> ; inline @@ -193,7 +194,7 @@ USE: continuations : ?tail* ( seq n -- seq/f ) (tail) ?subseq ; : accumulator ( quot -- quot vec ) - V{ } clone [ [ push ] curry compose ] keep ; + V{ } clone [ [ push ] curry compose ] keep ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/symbols/symbols-tests.factor b/extra/symbols/symbols-tests.factor old mode 100644 new mode 100755 index 84a61509c8..0eacbbfd38 --- a/extra/symbols/symbols-tests.factor +++ b/extra/symbols/symbols-tests.factor @@ -1,7 +1,15 @@ -USING: kernel symbols tools.test ; +USING: kernel symbols tools.test parser generic words ; IN: symbols.tests [ ] [ SYMBOLS: a b c ; ] unit-test [ a ] [ a ] unit-test [ b ] [ b ] unit-test [ c ] [ c ] unit-test + +DEFER: blah + +[ ] [ "IN: symbols.tests GENERIC: blah" eval ] unit-test +[ ] [ "IN: symbols.tests USE: symbols SYMBOLS: blah ;" eval ] unit-test + +[ f ] [ \ blah generic? ] unit-test +[ t ] [ \ blah symbol? ] unit-test diff --git a/extra/symbols/symbols.factor b/extra/symbols/symbols.factor old mode 100644 new mode 100755 index 8e074f4163..f6254f19de --- a/extra/symbols/symbols.factor +++ b/extra/symbols/symbols.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: parser sequences words ; +USING: parser sequences words kernel ; IN: symbols : SYMBOLS: - ";" parse-tokens [ create-in define-symbol ] each ; + ";" parse-tokens + [ create-in dup reset-generic define-symbol ] each ; parsing