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

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

db4
Eduardo Cavazos 2008-03-15 15:08:22 -06:00
parent d8e8fb253a 8d617d8604
commit ddd5d544e2
42 changed files with 451 additions and 172 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/continuations/continuations-docs.factor
View File

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

8
core/io/files/files-tests.factor
View File

@ -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

9
core/kernel/kernel-docs.factor
View File

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

10
extra/assocs/lib/lib.factor
View File

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

5
extra/db/db-tests.factor Executable file
View File

@ -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

4
extra/db/postgresql/postgresql.factor
View File

@ -119,8 +119,8 @@ M: postgresql-db bind% ( spec -- )
: postgresql-make ( class quot -- )
>r sql-props r>
[ postgresql-counter off ] swap compose
{ "" { } { } } nmake <postgresql-statement> ;
[ postgresql-counter off call ] { "" { } { } } nmake
<postgresql-statement> ; inline
: create-table-sql ( class -- statement )
[

2
extra/db/sqlite/ffi/ffi.factor
View File

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

2
extra/db/sqlite/sqlite.factor
View File

@ -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 )
[

6
extra/db/tuples/tuples-tests.factor
View File

@ -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

2
extra/db/tuples/tuples.factor
View File

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

1
extra/http/client/client-tests.factor
View File

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

1
extra/http/http.factor
View File

@ -180,6 +180,7 @@ cookies ;
request construct-empty
"1.1" >>version
http-port >>port
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies ;

15
extra/http/server/actions/actions-tests.factor
View File

@ -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
<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

11
extra/http/server/actions/actions.factor
View File

@ -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> ] [

4
extra/http/server/auth/login/login.factor
View File

@ -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

4
extra/http/server/auth/providers/assoc/assoc-tests.factor
View File

@ -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

12
extra/http/server/auth/providers/assoc/assoc.factor
View File

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

7
extra/http/server/auth/providers/db/db-tests.factor
View File

@ -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 ] [
<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

13
extra/http/server/auth/providers/db/db.factor
View File

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

12
extra/http/server/auth/providers/null/null.factor
View File

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

2
extra/http/server/auth/providers/providers.factor
View File

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

2
extra/http/server/callbacks/callbacks.factor
View File

@ -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

8
extra/http/server/components/components-tests.factor
View File

@ -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

7
extra/http/server/components/components.factor
View File

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

44
extra/http/server/server.factor
View File

@ -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 [
2nip
] [
default>> [
call-responder
] [
drop f
] if*
] if*
find-responder call-responder
] [
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 ;

95
extra/http/server/sessions/sessions-tests.factor
View File

@ -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> 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
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
[ ] [
<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

125
extra/http/server/sessions/sessions.factor
View File

@ -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>
construct-delegate ; inline
>r <sessions-in-memory> session-manager construct-boa
r> construct-delegate ; inline
TUPLE: session manager id namespace alarm ;
SYMBOLS: session session-id session-changed? ;
: <session> ( manager -- session )
f H{ } clone <box> \ 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> 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 )
[ <session> 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 )
[ <session-saver> 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 <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 )
>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 ( -- )
<input
"hidden" =type
sess-id =id
sess-id =name
\ session get id>> =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*
<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
f swap new-session sess-id associate <temporary-redirect>
] if* ;
2drop nip new-url-session
] if ;
TUPLE: cookie-sessions ;
: <cookie-sessions> ( responder -- responder' )
cookie-sessions <session-manager> ;
: 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 ;
: <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
[ over get-session call-responder/session ] keep
<session-cookie> put-cookie
] if* ;
2drop call-responder/new-session
] if ;

38
extra/http/server/sessions/storage/assoc/assoc.factor Executable file
View File

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

24
extra/http/server/sessions/storage/db/db-tests.factor Executable file
View File

@ -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

52
extra/http/server/sessions/storage/db/db.factor Executable file
View File

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

14
extra/http/server/sessions/storage/storage.factor Executable file
View File

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

3
extra/http/server/validators/validators-tests.factor
View File

@ -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

3
extra/http/server/validators/validators.factor
View File

@ -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

2
extra/io/windows/files/files.factor
View File

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

7
extra/io/windows/windows.factor
View File

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

6
extra/logging/server/server.factor
View File

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

6
extra/namespaces/lib/lib-tests.factor Executable file
View File

@ -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

24
extra/namespaces/lib/lib.factor Normal file → Executable file
View File

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

3
extra/sequences/lib/lib-tests.factor
View File

@ -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

9
extra/sequences/lib/lib.factor
View File

@ -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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

10
extra/symbols/symbols-tests.factor Normal file → Executable file
View File

@ -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

7
extra/symbols/symbols.factor Normal file → Executable file
View File

@ -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