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

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:"

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 <file-appender> dispose ] unit-test

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" } }

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 ;

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

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
+    [ postgresql-counter off call ] { "" { } { } } nmake
-    { "" { } { } } nmake <postgresql-statement> ;
+    <postgresql-statement> ; inline
 
 : create-table-sql ( class -- statement )
     [

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 ) ;

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 <simple-statement> ;
+    { "" { } { } } nmake <simple-statement> ; inline
 
 M: sqlite-db create-sql-statement ( class -- statement )
     [

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

extra/db/tuples/tuples.factor

@@ -36,7 +36,7 @@ HOOK: <update-tuples-statement> db ( class -- obj )
 HOOK: <delete-tuple-statement> db ( class -- obj )
 HOOK: <delete-tuples-statement> db ( class -- obj )
 
-HOOK: <select-by-slots-statement> db ( tuple -- tuple )
+HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
 
 HOOK: insert-tuple* db ( tuple statement -- )
 

extra/http/client/client-tests.factor

@@ -18,6 +18,7 @@ tuple-syntax namespaces ;
         port: 80
         version: "1.1"
         cookies: V{ }
+        header: H{ }
     }
 ] [
     [

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 ;
 

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
+USING: http.server.actions http.server.validators
-multiline namespaces http io.streams.string http.server
+tools.test math math.parser multiline namespaces http
-sequences accessors ;
+io.streams.string http.server sequences accessors ;
+
+[
+    "a" [ v-number ] { { "a" "123" } } validate-param
+    [ 123 ] [ "a" get ] unit-test
+] with-scope
 
 <action>
     [ "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
 
 <action>
     [ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
-    { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
+    { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
 "action-2" set
 
 STRING: action-request-test-2

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? )
+:: validate-param ( name validator assoc -- )
-    swap pick
+    name assoc at validator with-validator name set ; inline
-    >r >r at r> with-validator swap r> set ;
 
 : 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> ] [

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 <permanent-redirect> ] when
+                previous-page sget f <permanent-redirect>
             ] >>submit
     ] ;
 
@@ -347,7 +347,7 @@ M: login call-responder ( path responder -- response )
         swap <protected> >>default
         <login-action> "login" add-responder
         <logout-action> "logout" add-responder
-        no >>users ;
+        no-users >>users ;
 
 ! ! ! Configuration
 

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 ;
 
-<in-memory> "provider" set
+<users-in-memory> "provider" set
 
 [ t ] [
     <user>
@@ -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
 

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 ;
 
-: <in-memory> ( -- provider )
+: <users-in-memory> ( -- provider )
-    H{ } clone in-memory construct-boa ;
+    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 ;

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
+    init-users-table
-    [ user create-table ] ignore-errors
 
     [ t ] [
         <user>
@@ -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
 

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 ;
+SINGLETON: users-in-db
-
-: from-db T{ from-db } ;
 
 : find-user ( username -- user )
     <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 ;

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-users update-user 2drop ;
-
-M: no update-user 2drop ;

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
     ] ;
 

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

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" <text> validate = ] unit-test

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 ;
 
 : <number> ( id -- component ) number <component> ;
 
 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 ;
 
 : <text> ( id -- component ) text <component> ;
 
-M: text validate* 2drop ;
+M: text validate* drop ;
 
 M: text render-view*
     drop write ;

extra/http/server/server.factor

@@ -108,10 +108,6 @@ TUPLE: dispatcher default responders ;
 : <dispatcher> ( -- dispatcher )
     404-responder get H{ } clone dispatcher construct-boa ;
 
-: set-main ( dispatcher name -- dispatcher )
-    '[ , f <permanent-redirect> ] <trivial-responder>
-    >>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 [
+        find-responder call-responder
-            2nip
-        ] [
-            default>> [
-                call-responder
-            ] [
-                drop f
-            ] if*
-        ] if*
     ] [
         2drop redirect-with-/
     ] if ;
 
+: <webapp> ( class -- dispatcher )
+    <dispatcher> swap construct-delegate ; inline
+
+TUPLE: vhost-dispatcher default responders ;
+
+: <vhost-dispatcher> ( -- 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 <permanent-redirect> ] <trivial-responder>
+    >>default ;
+
 : add-responder ( dispatcher responder path -- dispatcher )
     pick responders>> set-at ;
 
 : add-main-responder ( dispatcher responder path -- dispatcher )
     [ add-responder ] keep set-main ;
 
-: <webapp> ( class -- dispatcher )
-    <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 ;

extra/http/server/sessions/sessions-tests.factor

@@ -1,6 +1,8 @@
 IN: http.server.sessions.tests
-USING: tools.test http.server.sessions math namespaces
+USING: tools.test http http.server.sessions
-kernel accessors ;
+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> foo
 
 M: foo init-session* drop 0 "x" sset ;
 
-f <session> "123" >>id [
+M: foo call-responder
+    2drop
+    "x" [ 1+ ] schange
+    "text/html" <content> [ "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 <session> "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> url-sessions? ] unit-test
 [ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
 
 [ ] [
     <foo> <url-sessions>
+        <sessions-in-memory> >>sessions
     "manager" set
 ] unit-test
 
 [ { 5 0 } ] [
     [
-        "manager" get new-session
+        "manager" get begin-session drop
-        dup "manager" get get-session [ 5 "a" sset ] with-session
+        dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session
-        dup "manager" get get-session [ "a" sget , ] with-session
+        dup "manager" get sessions>> get-session [ "a" sget , ] with-session
-        dup "manager" get get-session [ "x" sget , ] with-session
+        dup "manager" get sessions>> get-session [ "x" sget , ] with-session
-        "manager" get get-session delete-session
+        "manager" get sessions>> get-session
+        "manager" get sessions>> delete-session
     ] { } make
 ] unit-test
+
+[ ] [
+    <request>
+        "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
+    [
+        <request>
+        "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
+
+[ ] [
+    <foo> <cookie-sessions>
+        <sessions-in-memory> >>sessions
+    "manager" set
+] unit-test
+
+[
+    <request>
+    "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
+    [
+        <request>
+        "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

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 ;
 
 : <session-manager> ( responder class -- responder' )
-    >r H{ } clone session-manager construct-boa r>
+    >r <sessions-in-memory> session-manager construct-boa
-    construct-delegate ; inline
+    r> construct-delegate ; inline
 
-TUPLE: session manager id namespace alarm ;
+SYMBOLS: session session-id session-changed? ;
 
-: <session> ( manager -- session )
+: sget ( key -- value )
-    f H{ } clone <box> \ session construct-boa ;
+    session get at ;
 
-: timeout ( -- dt ) 20 minutes ;
+: sset ( value key -- )
+    session get set-at
+    session-changed? on ;
 
-: cancel-timeout ( session -- )
+: schange ( key quot -- )
-    alarm>> [ cancel-alarm ] if-box? ;
+    session get swap change-at
+    session-changed? on ; inline
 
-: delete-session ( session -- )
+: sessions session-manager get sessions>> ;
-    [ cancel-timeout ]
-    [ dup manager>> sessions>> delete-at ]
-    bi ;
 
-: touch-session ( session -- session )
+: managed-responder session-manager get responder>> ;
-    [ cancel-timeout ]
-    [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
-    [ ]
-    tri ;
 
-: 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> session-saver
 
-: init-session ( session -- session )
+M: session-saver dispose
-    dup dup \ session [
+    session-changed? get [
-        manager>> responder>> init-session*
+        [ session>> ] [ id>> ] bi
-    ] with-variable ;
+        sessions update-session
+    ] [ drop ] if ;
 
-: new-session ( responder -- id )
+: call-responder/session ( path responder id session -- response )
-    [ <session> init-session touch-session ]
+    [ <session-saver> add-always-destructor ]
-    [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
+    [ [ session-id set ] [ session set ] bi* ] 2bi
-    bi id>> ;
+    [ session-manager set ] [ responder>> call-responder ] bi ;
-
-: 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 ;
 
 TUPLE: null-sessions ;
 
@@ -74,56 +67,64 @@ TUPLE: null-sessions ;
     null-sessions <session-manager> ;
 
 M: null-sessions call-responder ( path responder -- response )
-    dup <session> call-responder/session ;
+    H{ } clone f call-responder/session ;
 
 TUPLE: url-sessions ;
 
 : <url-sessions> ( responder -- responder' )
     url-sessions <session-manager> ;
 
-: sess-id "factorsessid" ;
+: session-id-key "factorsessid" ;
 
-: current-session ( responder -- session )
+: current-url-session ( responder -- id/f session/f )
-    >r request-params sess-id swap at r> get-session ;
+    [ 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 ( -- )
     <input
         "hidden" =type
-    sess-id =id
+        session-id-key =id
-    sess-id =name
+        session-id-key =name
-    \ session get id>> =value
+        session-id get =value
     input/> ;
 
+: new-url-session ( responder -- response )
+    [ f ] [ begin-session drop session-id-key associate ] bi*
+    <temporary-redirect> ;
+
 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
+        2drop nip new-url-session
-        f swap new-session sess-id associate <temporary-redirect>
+    ] if ;
-    ] if* ;
 
 TUPLE: cookie-sessions ;
 
 : <cookie-sessions> ( responder -- responder' )
     cookie-sessions <session-manager> ;
 
-: get-session-cookie ( responder -- cookie )
+: current-cookie-session ( responder -- id namespace/f )
-    request get sess-id get-cookie
+    request get session-id-key get-cookie dup
-    [ value>> swap get-session ] [ drop f ] if* ;
+    [ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
 
 : <session-cookie> ( id -- cookie )
-    sess-id <cookie> ;
+    session-id-key <cookie> ;
+
+: call-responder/new-session ( path responder -- response )
+    dup begin-session
+    [ call-responder/session ]
+    [ drop <session-cookie> ] 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
+        2drop call-responder/new-session
-        [ over get-session call-responder/session ] keep
+    ] if ;
-        <session-cookie> put-cookie
-    ] if* ;

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 ;
+
+: <sessions-in-memory> ( -- 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 ;

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

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 ;
+
+: <session> ( 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 [
+        <session>
+        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
+    <session>
+        swap  global [ dup . ] bind >>namespace
+    dup update-tuple
+    id>> <session> select-tuple global [ . flush ] bind
+    ;
+
+M: sessions-in-db delete-session ( id storage -- )
+    drop
+    <session>
+    delete-tuple ;
+
+M: sessions-in-db new-session ( namespace storage -- id )
+    global [ "new " print flush ] bind
+    drop
+    f <session>
+        swap  global [ dup . ] bind >>namespace
+    [ insert-tuple ] [ id>> number>string ] bi ;

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 )

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

extra/http/server/validators/validators.factor

@@ -40,6 +40,9 @@ C: <validation-error> 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

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+ ;
 

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 [
+    [ dup file-info file-info-size ] [ drop 0 ] recover
-        >r (open-append) r> 2dup set-file-pointer
+    >r (open-append) r> 2dup set-file-pointer ;
-    ] [
-        drop open-write
-    ] if ;
 
 TUPLE: FileArgs
     hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;

extra/logging/server/server.factor

@@ -4,7 +4,7 @@ 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 ;
+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 <file-appender> ;
+    1 log# utf8 <file-appender> ;
 
 : log-stream ( service -- stream )
     log-files get [ open-log-stream ] cache ;

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

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 )
+MACRO:: nmake ( quot exemplars -- )
-    dup length dup zero? [ 1+ ] when
+    [let | n [ exemplars length ] |
         [
             [
-            [ drop 1024 swap new-resizable ] 2map
+                exemplars
-            [ building-seq set call ] keep
+                [ 0 swap new-resizable ] map
-        ] 2keep >r [ like ] 2map r> firstn 
+                building-seq set
-    ] with-scope ;
+
+                quot call
+
+                building-seq get
+                exemplars [ like ] 2map
+                n firstn
+            ] with-scope
+        ]
+    ] ;

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

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
+    [ [ swap nth ] curry [ keep ] curry ] map
-    [ keep ] curry ] map concat [ drop ] compose ;
+    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
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

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

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