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

Merge branch 'master' into experimental2

db4
Alex Chapman 2008-03-12 13:39:37 +11:00
parent 2f505f85d1 ae3963a072
commit 74a5479268
61 changed files with 1672 additions and 591 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
core/parser/parser.factor
View File

@ -240,13 +240,13 @@ PREDICATE: unexpected unexpected-eof
: CREATE ( -- word ) scan create-in ;
: create-class ( word vocab -- word )
create
: create-class-in ( word -- word )
in get create
dup save-class-location
dup predicate-word dup set-word save-location ;
: CREATE-CLASS ( -- word )
scan in get create-class ;
scan create-class-in ;
: word-restarts ( possibilities -- restarts )
natural-sort [

3
core/sequences/sequences.factor
View File

@ -441,6 +441,9 @@ PRIVATE>
: memq? ( obj seq -- ? )
[ eq? ] with contains? ;
: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
swap [ member? ] curry subset ;
: remove ( obj seq -- newseq )
[ = not ] with subset ;

6
core/splitting/splitting.factor Normal file → Executable file
View File

@ -69,12 +69,12 @@ INSTANCE: groups sequence
: split ( seq separators -- pieces ) [ split, ] { } make ;
: string-lines ( str -- seq )
dup [ "\r\n" member? ] contains? [
dup "\r\n" seq-intersect empty? [
1array
] [
"\n" split [
1 head-slice* [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split add concat
] [
1array
] if ;

2
extra/builder/builder.factor Normal file → Executable file
View File

@ -164,7 +164,7 @@ SYMBOL: builder-recipients
builder-recipients get >>to
subject >>subject
"./report" file>string >>body
send ;
send-email ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

27
extra/db/postgresql/ffi/ffi.factor
View File

@ -270,7 +270,8 @@ FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
FUNCTION: char* PQoidStatus ( PGresult* res ) ;
FUNCTION: Oid PQoidValue ( PGresult* res ) ;
FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
! FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: void* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
@ -297,8 +298,8 @@ FUNCTION: size_t PQescapeStringConn ( PGconn* conn,
FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn,
char* from, size_t length,
size_t* to_length ) ;
FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
size_t* retbuflen ) ;
FUNCTION: void* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
! FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
! These forms are deprecated!
FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
@ -346,3 +347,23 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
! Get encoding id from environment variable PGCLIENTENCODING
FUNCTION: int PQenv2encoding ( ) ;
! From git, include/catalog/pg_type.h
: BOOL-OID 16 ; inline
: BYTEA-OID 17 ; inline
: CHAR-OID 18 ; inline
: NAME-OID 19 ; inline
: INT8-OID 20 ; inline
: INT2-OID 21 ; inline
: INT4-OID 23 ; inline
: TEXT-OID 23 ; inline
: OID-OID 26 ; inline
: FLOAT4-OID 700 ; inline
: FLOAT8-OID 701 ; inline
: VARCHAR-OID 1043 ; inline
: DATE-OID 1082 ; inline
: TIME-OID 1083 ; inline
: TIMESTAMP-OID 1114 ; inline
: TIMESTAMPTZ-OID 1184 ; inline
: INTERVAL-OID 1186 ; inline
: NUMERIC-OID 1700 ; inline

146
extra/db/postgresql/lib/lib.factor
View File

@ -3,7 +3,9 @@
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser
combinators combinators.cleave ;
combinators combinators.cleave libc shuffle calendar.format
byte-arrays destructors prettyprint new-slots accessors
strings serialize io.encodings.binary io.streams.byte-array ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
@ -39,32 +41,130 @@ IN: db.postgresql.lib
dup postgresql-result-error-message swap PQclear throw
] unless ;
: type>oid ( symbol -- n )
dup array? [ first ] when
{
{ BLOB [ BYTEA-OID ] }
{ FACTOR-BLOB [ BYTEA-OID ] }
[ drop 0 ]
} case ;
: type>param-format ( symbol -- n )
dup array? [ first ] when
{
{ BLOB [ 1 ] }
{ FACTOR-BLOB [ 1 ] }
[ drop 0 ]
} case ;
: param-types ( statement -- seq )
statement-in-params
[ sql-spec-type type>oid ] map
>c-uint-array ;
: malloc-byte-array/length
[ malloc-byte-array dup free-always ] [ length ] bi ;
: param-values ( statement -- seq seq2 )
[ statement-bind-params ]
[ statement-in-params ] bi
[
sql-spec-type {
{ FACTOR-BLOB [
dup [
binary [ serialize ] with-byte-writer
malloc-byte-array/length ] [ 0 ] if ] }
{ BLOB [
dup [ malloc-byte-array/length ] [ 0 ] if ] }
[
drop number>string* dup [
malloc-char-string dup free-always
] when 0
]
} case 2array
] 2map flip dup empty? [
drop f f
] [
first2 [ >c-void*-array ] [ >c-uint-array ] bi*
] if ;
: param-formats ( statement -- seq )
statement-in-params
[ sql-spec-type type>param-format ] map
>c-uint-array ;
: do-postgresql-bound-statement ( statement -- res )
>r db get db-handle r>
[ statement-sql ] keep
[ statement-bind-params length f ] keep
statement-bind-params
[ number>string* malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] unless ;
[
>r db get db-handle r>
{
[ statement-sql ]
[ statement-bind-params length ]
[ param-types ]
[ param-values ]
[ param-formats ]
} cleave
0 PQexecParams dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] unless
] with-destructors ;
: pq-get-is-null ( handle row column -- ? )
PQgetisnull 1 = ;
: pq-get-string ( handle row column -- obj )
3dup PQgetvalue alien>char-string
dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
: pq-get-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ;
TUPLE: postgresql-malloc-destructor alien ;
C: <postgresql-malloc-destructor> postgresql-malloc-destructor
M: postgresql-malloc-destructor dispose ( obj -- )
alien>> PQfreemem ;
: postgresql-free-always ( alien -- )
<postgresql-malloc-destructor> add-always-destructor ;
: pq-get-blob ( handle row column -- obj/f )
[ PQgetvalue ] 3keep 3dup PQgetlength
dup 0 > [
3nip
[
memory>byte-array >string
0 <uint>
[
PQunescapeBytea dup zero? [
postgresql-result-error-message throw
] [
dup postgresql-free-always
] if
] keep
*uint memory>byte-array
] with-destructors
] [
drop pq-get-is-null nip [ f ] [ B{ } clone ] if
] if ;
: postgresql-column-typed ( handle row column type -- obj )
dup array? [ first ] when
{
{ +native-id+ [ ] }
{ INTEGER [ PQgetvalue string>number ] }
{ BIG-INTEGER [ PQgetvalue string>number ] }
{ DOUBLE [ PQgetvalue string>number ] }
{ TEXT [ PQgetvalue ] }
{ VARCHAR [ PQgetvalue ] }
{ DATE [ PQgetvalue ] }
{ TIME [ PQgetvalue ] }
{ TIMESTAMP [ PQgetvalue ] }
{ DATETIME [ PQgetvalue ] }
{ BLOB [ [ PQgetvalue ] 3keep PQgetlength ] }
{ FACTOR-BLOB [ [ PQgetvalue ] 3keep PQgetlength ] }
{ +native-id+ [ pq-get-number ] }
{ INTEGER [ pq-get-number ] }
{ BIG-INTEGER [ pq-get-number ] }
{ DOUBLE [ pq-get-number ] }
{ TEXT [ pq-get-string ] }
{ VARCHAR [ pq-get-string ] }
{ DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
{ TIME [ pq-get-string dup [ hms>timestamp ] when ] }
{ TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
{ DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
{ BLOB [ pq-get-blob ] }
{ FACTOR-BLOB [
pq-get-blob
dup [ binary [ deserialize ] with-byte-reader ] when ] }
[ no-sql-type ]
} case ;
! PQgetlength PQgetisnull
! PQgetlength PQgetisnull

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

@ -55,7 +55,7 @@ M: postgresql-result-set #columns ( result-set -- n )
result-set-handle PQnfields ;
M: postgresql-result-set row-column ( result-set column -- obj )
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
>r dup result-set-handle swap result-set-n r> pq-get-string ;
M: postgresql-result-set row-column-typed ( result-set column -- obj )
dup pick result-set-out-params nth sql-spec-type
@ -238,10 +238,13 @@ M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
" where " 0%
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
";" 0%
dup empty? [
drop
] [
" where " 0%
[ " and " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
] if ";" 0%
] postgresql-make ;
M: postgresql-db type-table ( -- hash )
@ -251,7 +254,12 @@ M: postgresql-db type-table ( -- hash )
{ VARCHAR "varchar" }
{ INTEGER "integer" }
{ DOUBLE "real" }
{ DATE "date" }
{ TIME "time" }
{ DATETIME "timestamp" }
{ TIMESTAMP "timestamp" }
{ BLOB "bytea" }
{ FACTOR-BLOB "bytea" }
} ;
M: postgresql-db create-type-table ( -- hash )

5
extra/db/sqlite/lib/lib.factor
View File

@ -3,7 +3,8 @@
USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary ;
io.streams.byte-array byte-arrays io.encodings.binary
tools.walker ;
IN: db.sqlite.lib
: sqlite-error ( n -- * )
@ -137,7 +138,7 @@ IN: db.sqlite.lib
{ BLOB [ sqlite-column-blob ] }
{ FACTOR-BLOB [
sqlite-column-blob
binary [ deserialize ] with-byte-reader
dup [ binary [ deserialize ] with-byte-reader ] when
] }
! { NULL [ 2drop f ] }
[ no-sql-type ]

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

@ -3,10 +3,12 @@
USING: io.files kernel tools.test db db.tuples
db.types continuations namespaces math
prettyprint tools.walker db.sqlite calendar
math.intervals ;
math.intervals db.postgresql ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real ts date time blob ;
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob ;
: <person> ( name age real ts date time blob -- person )
{
set-person-the-name
@ -16,9 +18,10 @@ TUPLE: person the-id the-name the-number the-real ts date time blob ;
set-person-date
set-person-time
set-person-blob
set-person-factor-blob
} person construct ;
: <assigned-person> ( id name age real ts date time blob -- person )
: <assigned-person> ( id name age real ts date time blob factor-blob -- person )
<person> [ set-person-the-id ] keep ;
SYMBOL: person1
@ -82,6 +85,23 @@ SYMBOL: person4
}
] [ T{ person f 3 } select-tuple ] unit-test
[ ] [ person4 get insert-tuple ] unit-test
[
T{
person
f
4
"eddie"
10
3.14
T{ timestamp f 2008 3 5 16 24 11 0 }
T{ timestamp f 2008 11 22 f f f f }
T{ timestamp f f f f 12 34 56 f }
f
H{ { 1 2 } { 3 4 } { 5 "lol" } }
}
] [ T{ person f 4 } select-tuple ] unit-test
[ ] [ person drop-table ] unit-test ;
: make-native-person-table ( -- )
@ -102,10 +122,12 @@ SYMBOL: person4
{ "date" "D" DATE }
{ "time" "T" TIME }
{ "blob" "B" BLOB }
{ "factor-blob" "FB" FACTOR-BLOB }
} define-persistent
"billy" 10 3.14 f f f f <person> person1 set
"johnny" 10 3.14 f f f f <person> person2 set
"teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } <person> person3 set ;
"billy" 10 3.14 f f f f f <person> person1 set
"johnny" 10 3.14 f f f f f <person> person2 set
"teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
"eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
: assigned-person-schema ( -- )
person "PERSON"
@ -118,10 +140,12 @@ SYMBOL: person4
{ "date" "D" DATE }
{ "time" "T" TIME }
{ "blob" "B" BLOB }
{ "factor-blob" "FB" FACTOR-BLOB }
} define-persistent
1 "billy" 10 3.14 f f f f <assigned-person> person1 set
2 "johnny" 10 3.14 f f f f <assigned-person> person2 set
3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } <assigned-person> person3 set ;
1 "billy" 10 3.14 f f f f f <assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f <assigned-person> person2 set
3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <assigned-person> person3 set
4 "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
@ -161,12 +185,15 @@ TUPLE: annotation n paste-id summary author mode contents ;
: test-sqlite ( quot -- )
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
! : test-postgresql ( -- )
! >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
: test-postgresql ( -- )
>r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
TUPLE: serialize-me id data ;
: test-serialize ( -- )
@ -183,7 +210,8 @@ TUPLE: serialize-me id data ;
{ T{ serialize-me f 1 H{ { 1 2 } } } }
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
! [ test-serialize ] test-sqlite
[ test-serialize ] test-sqlite
[ test-serialize ] test-postgresql
TUPLE: exam id name score ;

7
extra/fry/fry.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting
quotations arrays namespaces ;
quotations arrays namespaces qualified ;
QUALIFIED: namespaces
IN: fry
: , "Only valid inside a fry" throw ;
@ -23,6 +24,10 @@ DEFER: (fry)
unclip {
{ , [ [ curry ] ((fry)) ] }
{ @ [ [ compose ] ((fry)) ] }
! to avoid confusion, remove if fry goes core
{ namespaces:, [ [ curry ] ((fry)) ] }
[ swap >r add r> (fry) ]
} case
] if ;

7
extra/http/client/client.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors io.encodings.latin1
io.encodings.binary ;
splitting calendar continuations accessors vectors
io.encodings.latin1 io.encodings.binary fry ;
IN: http.client
DEFER: http-request
@ -46,8 +46,7 @@ DEFER: http-request
dup host>> swap port>> <inet> ;
: close-on-error ( stream quot -- )
[ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ;
inline
'[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
PRIVATE>

4
extra/http/http-tests.factor
View File

@ -137,10 +137,10 @@ io.encodings.ascii ;
[
<dispatcher>
<action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>get
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
"quit" add-responder
"extra/http/test" resource-path <static> >>default
default-host set
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
] with-scope

18
extra/http/http.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io io.streams.string kernel math namespaces
math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces
unicode.case combinators vectors sorting new-slots accessors
calendar calendar.format quotations arrays ;
USING: fry hashtables io io.streams.string kernel math
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
combinators vectors sorting new-slots accessors calendar
calendar.format quotations arrays ;
IN: http
: http-port 80 ; inline
@ -91,8 +91,8 @@ IN: http
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
dup [ "\r\n" member? ] contains?
[ "Header injection attack" throw ] when ;
dup "\r\n" seq-intersect empty?
[ "Header injection attack" throw ] unless ;
: write-header ( assoc -- )
>alist sort-keys [
@ -396,13 +396,13 @@ M: response write-full-response ( request response -- )
"content-type" set-header ;
: get-cookie ( request/response name -- cookie/f )
>r cookies>> r> [ swap name>> = ] curry find nip ;
>r cookies>> r> '[ , _ name>> = ] find nip ;
: delete-cookie ( request/response name -- )
over cookies>> >r get-cookie r> delete ;
: put-cookie ( request/response cookie -- request/response )
[ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
over cookies>> push ;
TUPLE: raw-response

6
extra/http/server/actions/actions-tests.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ multiline namespaces http io.streams.string http.server
sequences accessors ;
<action>
[ "a" get "b" get + ] >>get
[ "a" get "b" get + ] >>display
{ { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
"action-1" set
@ -16,12 +16,13 @@ blah
[ 25 ] [
action-request-test-1 [ read-request ] with-string-reader
request set
"/blah"
"action-1" get call-responder
] unit-test
<action>
[ +path+ get "xxx" get "X" <repetition> concat append ] >>post
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
{ { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
"action-2" set
@ -34,6 +35,7 @@ xxx=4
[ "/blahXXXX" ] [
action-request-test-2 [ read-request ] with-string-reader
request set
"/blah"
"action-2" get call-responder
] unit-test

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

@ -1,41 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! 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 ;
http.server http.server.validators http hashtables namespaces
combinators.cleave fry continuations ;
IN: http.server.actions
SYMBOL: +path+
TUPLE: action get get-params post post-params revalidate ;
SYMBOL: params
TUPLE: action init display submit get-params post-params ;
: <action>
action construct-empty
[ <400> ] >>get
[ <400> ] >>post
[ <400> ] >>revalidate ;
[ ] >>init
[ <400> ] >>display
[ <400> ] >>submit ;
: extract-params ( request path -- assoc )
>r dup method>> {
: extract-params ( path -- assoc )
+path+ associate
request get dup method>> {
{ "GET" [ query>> ] }
{ "HEAD" [ query>> ] }
{ "POST" [ post-data>> query>assoc ] }
} case r> +path+ associate union ;
} case union ;
: action-params ( request path param -- error? )
-rot extract-params validate-params ;
: with-validator ( string quot -- result error? )
'[ , @ f ] [
dup validation-error? [ t ] [ rethrow ] if
] recover ; inline
: get-action ( request path -- response )
action get get-params>> action-params
[ <400> ] [ action get get>> call ] if ;
: validate-param ( name validator assoc -- error? )
swap pick
>r >r at r> with-validator swap r> set ;
: post-action ( request path -- response )
: action-params ( validators -- error? )
[ params get validate-param ] { } assoc>map [ ] contains? ;
: handle-get ( -- response )
action get get-params>> action-params [ <400> ] [
action get [ init>> call ] [ display>> call ] bi
] if ;
: handle-post ( -- response )
action get post-params>> action-params
[ action get revalidate>> ] [ action get post>> ] if call ;
[ <400> ] [ action get submit>> call ] if ;
M: action call-responder ( request path action -- response )
action set
over request set
over method>>
{
{ "GET" [ get-action ] }
{ "POST" [ post-action ] }
} case ;
: validation-failed ( -- * )
action get display>> call exit-with ;
M: action call-responder ( path action -- response )
[ extract-params params set ]
[
action set
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case
] bi* ;

8
extra/http/server/auth/auth.factor Executable file
View File

@ -0,0 +1,8 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: http.server.sessions accessors ;
IN: http.server.auth
SYMBOL: logged-in-user
: uid ( -- string ) logged-in-user sget username>> ;

6
extra/http/server/auth/login/login-tests.factor Executable file
View File

@ -0,0 +1,6 @@
IN: http.server.auth.login.tests
USING: tools.test http.server.auth.login ;
\ <login> must-infer
\ allow-registration must-infer
\ allow-password-recovery must-infer

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

@ -2,68 +2,299 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.actions
http.server.sessions http.server.templating.fhtml http sequences
io.files namespaces ;
http.server.auth.providers http.server.auth.providers.null
http.server.actions http.server.components http.server.sessions
http.server.templating.fhtml http.server.validators
http.server.auth http sequences io.files namespaces hashtables
fry io.sockets combinators.cleave arrays threads locals
qualified ;
IN: http.server.auth.login
QUALIFIED: smtp
TUPLE: login-auth responder provider ;
TUPLE: login users ;
C: (login-auth) login-auth
SYMBOL: logged-in?
SYMBOL: provider
SYMBOL: post-login-url
SYMBOL: login-failed?
: login-page ( -- response )
"text/html" <content> [
"extra/http/server/auth/login/login.fhtml"
resource-path run-template-file
] >>body ;
! ! ! Login
: <login-action>
<action>
[ login-page ] >>get
: <login-form>
"login" <form>
"resource:extra/http/server/auth/login/login.fhtml" >>edit-template
"username" <username>
t >>required
add-field
"password" <password>
t >>required
add-field ;
{
{ "name" [ ] }
{ "password" [ ] }
} >>post-params
: successful-login ( user -- response )
logged-in-user sset
post-login-url sget f <permanent-redirect> ;
:: <login-action> ( -- action )
[let | form [ <login-form> ] |
<action>
[ blank-values ] >>init
[
"text/html" <content>
[ form edit-form ] >>body
] >>display
[
blank-values
form validate-form
"password" value "username" value
login get users>> check-login [
successful-login
] [
login-failed? on
validation-failed
] if*
] >>submit
] ;
! ! ! New user registration
: <register-form> ( -- form )
"register" <form>
"resource:extra/http/server/auth/login/register.fhtml" >>edit-template
"username" <username>
t >>required
add-field
"realname" <string> add-field
"password" <password>
t >>required
add-field
"verify-password" <password>
t >>required
add-field
"email" <email> add-field
"captcha" <captcha> add-field ;
SYMBOL: password-mismatch?
SYMBOL: user-exists?
: same-password-twice ( -- )
"password" value "verify-password" value = [
password-mismatch? on
validation-failed
] unless ;
:: <register-action> ( -- action )
[let | form [ <register-form> ] |
<action>
[ blank-values ] >>init
[
"text/html" <content>
[ form edit-form ] >>body
] >>display
[
blank-values
form validate-form
same-password-twice
<user> values get [
"username" get >>username
"realname" get >>realname
"password" get >>password
"email" get >>email
] bind
login get users>> new-user [
user-exists? on
validation-failed
] unless*
successful-login
] >>submit
] ;
! ! ! Password recovery
SYMBOL: lost-password-from
: current-host ( -- string )
request get host>> host-name or ;
: new-password-url ( user -- url )
"new-password"
swap [
[ username>> "username" set ]
[ ticket>> "ticket" set ]
bi
] H{ } make-assoc
derive-url ;
: password-email ( user -- email )
smtp:<email>
[ "[ " % current-host % " ] password recovery" % ] "" make >>subject
lost-password-from get >>from
over email>> 1array >>to
[
"password" get
"name" get
provider sget check-login [
t logged-in? sset
post-login-url sget <permanent-redirect>
] [
login-page
] if
] >>post ;
"This e-mail was sent by the application server on " % current-host % "\n" %
"because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
"login form, and requested a new password for the user named ``" %
over username>> % "''.\n" %
"\n" %
"If you believe that this request was legitimate, you may click the below link in\n" %
"your browser to set a new password for your account:\n" %
"\n" %
swap new-password-url %
"\n\n" %
"Love,\n" %
"\n" %
" FactorBot\n" %
] "" make >>body ;
: <logout-action>
: send-password-email ( user -- )
'[ , password-email smtp:send-email ]
"E-mail send thread" spawn drop ;
: <recover-form-1> ( -- form )
"register" <form>
"resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template
"username" <username>
t >>required
add-field
"email" <email>
t >>required
add-field
"captcha" <captcha> add-field ;
:: <recover-action-1> ( -- action )
[let | form [ <recover-form-1> ] |
<action>
[ blank-values ] >>init
[
"text/html" <content>
[ form edit-form ] >>body
] >>display
[
blank-values
form validate-form
"email" value "username" value
login get users>> issue-ticket [
send-password-email
] when*
"resource:extra/http/server/auth/login/recover-2.fhtml" serve-template
] >>submit
] ;
: <recover-form-3>
"new-password" <form>
"resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template
"username" <username> <hidden>
t >>required
add-field
"password" <password>
t >>required
add-field
"verify-password" <password>
t >>required
add-field
"ticket" <string> <hidden>
t >>required
add-field ;
:: <recover-action-3> ( -- action )
[let | form [ <recover-form-3> ] |
<action>
[
{ "username" [ v-required ] }
{ "ticket" [ v-required ] }
] >>get-params
[
[
"username" [ get ] keep set
"ticket" [ get ] keep set
] H{ } make-assoc values set
] >>init
[
"text/html" <content>
[ <recover-form-3> edit-form ] >>body
] >>display
[
blank-values
form validate-form
same-password-twice
"ticket" value
"username" value
login get users>> claim-ticket [
"password" value >>password
login get users>> update-user
"resource:extra/http/server/auth/login/recover-4.fhtml"
serve-template
] [
<400>
] if*
] >>submit
] ;
! ! ! Logout
: <logout-action> ( -- action )
<action>
[
f logged-in? sset
request get "login" <permanent-redirect>
] >>post ;
f logged-in-user sset
"login" f <permanent-redirect>
] >>submit ;
M: login-auth call-responder ( request path responder -- response )
logged-in? sget
[ responder>> call-responder ] [
pick method>> "GET" = [
nip
provider>> provider sset
dup request-url post-login-url sset
"login" f session-link <permanent-redirect>
] [
3drop <400>
] if
! ! ! Authentication logic
TUPLE: protected responder ;
C: <protected> protected
M: protected call-responder ( path responder -- response )
logged-in-user sget [ responder>> call-responder ] [
2drop
request get method>> { "GET" "HEAD" } member? [
request get request-url post-login-url sset
"login" f <permanent-redirect>
] [ <400> ] if
] if ;
: <login-auth> ( responder provider -- auth )
(login-auth)
<dispatcher>
swap >>default
<login-action> "login" add-responder
<logout-action> "logout" add-responder
<cookie-sessions> ;
M: login call-responder ( path responder -- response )
dup login set
delegate call-responder ;
: <login> ( responder -- auth )
login <webapp>
swap <protected> >>default
<login-action> "login" add-responder
<logout-action> "logout" add-responder
no >>users ;
! ! ! Configuration
: allow-registration ( login -- login )
<register-action> "register" add-responder ;
: allow-password-recovery ( login -- login )
<recover-action-1> "recover-password" add-responder
<recover-action-3> "new-password" add-responder ;
: allow-registration? ( -- ? )
login get responders>> "register" swap key? ;
: allow-password-recovery? ( -- ? )
login get responders>> "recover-password" swap key? ;

22
extra/http/server/auth/login/login.fhtml
View File

@ -1,3 +1,5 @@
<% USING: http.server.auth.login http.server.components kernel
namespaces ; %>
<html>
<body>
<h1>Login required</h1>
@ -7,19 +9,33 @@
<tr>
<td>User name:</td>
<td><input name="name" /></td>
<td><% "username" component render-edit %></td>
</tr>
<tr>
<td>Password:</td>
<td><input type="password" name="password" /></td>
<td><% "password" component render-edit %></td>
</tr>
</table>
<input type="submit" value="Log in" />
<p><input type="submit" value="Log in" />
<%
login-failed? get
[ "Invalid username or password" render-error ] when
%>
</p>
</form>
<p>
<% allow-registration? [ %>
<a href="register">Register</a>
<% ] when %>
<% allow-password-recovery? [ %>
<a href="recover-password">Recover Password</a>
<% ] when %>
</p>
</body>
</html>

38
extra/http/server/auth/login/recover-1.fhtml Executable file
View File

@ -0,0 +1,38 @@
<% USING: http.server.components ; %>
<html>
<body>
<h1>Recover lost password: step 1 of 4</h1>
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
<form method="POST" action="recover-password">
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-edit %></td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td>Captcha:</td>
<td><% "captcha" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
</tr>
</table>
<input type="submit" value="Recover password" />
</form>
</body>
</html>

9
extra/http/server/auth/login/recover-2.fhtml Executable file
View File

@ -0,0 +1,9 @@
<% USING: http.server.components ; %>
<html>
<body>
<h1>Recover lost password: step 2 of 4</h1>
<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
</body>
</html>

43
extra/http/server/auth/login/recover-3.fhtml Executable file
View File

@ -0,0 +1,43 @@
<% USING: http.server.components http.server.auth.login
namespaces kernel combinators ; %>
<html>
<body>
<h1>Recover lost password: step 3 of 4</h1>
<p>Choose a new password for your account.</p>
<form method="POST" action="new-password">
<table>
<% "username" component render-edit %>
<% "ticket" component render-edit %>
<tr>
<td>Password:</td>
<td><% "password" component render-edit %></td>
</tr>
<tr>
<td>Verify password:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
</table>
<p><input type="submit" value="Set password" />
<% password-mismatch? get [
"passwords do not match" render-error
] when %>
</p>
</form>
</body>
</html>

10
extra/http/server/auth/login/recover-4.fhtml Executable file
View File

@ -0,0 +1,10 @@
<% USING: http.server.components http.server.auth.login
namespaces kernel combinators ; %>
<html>
<body>
<h1>Recover lost password: step 4 of 4</h1>
<p>Your password has been reset. You may now <a href="login">log in</a>.</p>
</body>
</html>

75
extra/http/server/auth/login/register.fhtml Executable file
View File

@ -0,0 +1,75 @@
<% USING: http.server.components http.server.auth.login
namespaces kernel combinators ; %>
<html>
<body>
<h1>New user registration</h1>
<form method="POST" action="register">
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-edit %></td>
</tr>
<tr>
<td>Real name:</td>
<td><% "realname" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<td>Password:</td>
<td><% "password" component render-edit %></td>
</tr>
<tr>
<td>Verify:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
<tr>
<td>Captcha:</td>
<td><% "captcha" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
</tr>
</table>
<p><input type="submit" value="Register" />
<% {
{ [ password-mismatch? get ] [ "passwords do not match" render-error ] }
{ [ user-exists? get ] [ "username taken" render-error ] }
{ [ t ] [ ] }
} cond %>
</p>
</form>
</body>
</html>

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

@ -1,18 +1,33 @@
IN: http.server.auth.providers.assoc.tests
USING: http.server.auth.providers
http.server.auth.providers.assoc tools.test
namespaces ;
namespaces accessors kernel ;
<assoc-auth-provider> "provider" set
<in-memory> "provider" set
"slava" "provider" get new-user
[ t ] [
<user>
"slava" >>username
"foobar" >>password
"slava@factorcode.org" >>email
"provider" get new-user
username>> "slava" =
] unit-test
[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with
[ f ] [
<user>
"slava" >>username
"provider" get new-user
] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with
[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
"fdasf" "slava" "provider" get set-password
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test

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

@ -4,20 +4,16 @@ IN: http.server.auth.providers.assoc
USING: new-slots accessors assocs kernel
http.server.auth.providers ;
TUPLE: assoc-auth-provider assoc ;
TUPLE: in-memory assoc ;
: <assoc-auth-provider> ( -- provider )
H{ } clone assoc-auth-provider construct-boa ;
: <in-memory> ( -- provider )
H{ } clone in-memory construct-boa ;
M: assoc-auth-provider check-login
assoc>> at = ;
M: in-memory get-user ( username provider -- user/f )
assoc>> at ;
M: assoc-auth-provider new-user
assoc>>
2dup key? [ drop user-exists ] when
t -rot set-at ;
M: in-memory update-user ( user provider -- ) 2drop ;
M: assoc-auth-provider set-password
assoc>>
2dup key? [ drop no-such-user ] unless
set-at ;
M: in-memory new-user ( user provider -- user/f )
>r dup username>> r> assoc>>
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;

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

@ -2,24 +2,39 @@ IN: http.server.auth.providers.db.tests
USING: http.server.auth.providers
http.server.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files ;
io.files accessors kernel ;
db-auth-provider "provider" set
from-db "provider" set
"auth-test.db" temp-file sqlite-db [
[ user drop-table ] ignore-errors
[ user create-table ] ignore-errors
"slava" "provider" get new-user
[ t ] [
<user>
"slava" >>username
"foobar" >>password
"slava@factorcode.org" >>email
"provider" get new-user
username>> "slava" =
] unit-test
[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with
[ f ] [
<user>
"slava" >>username
"provider" get new-user
] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with
[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
"fdasf" "slava" "provider" get set-password
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
] with-db

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

@ -1,53 +1,45 @@
! 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 ;
http.server.auth.providers kernel continuations ;
IN: http.server.auth.providers.db
TUPLE: user name password ;
: <user> user construct-empty ;
user "USERS"
{
{ "name" "NAME" { VARCHAR 256 } +assigned-id+ }
{ "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
{ "realname" "REALNAME" { VARCHAR 256 } }
{ "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
{ "email" "EMAIL" { VARCHAR 256 } }
{ "ticket" "TICKET" { VARCHAR 256 } }
{ "profile" "PROFILE" FACTOR-BLOB }
} define-persistent
: init-users-table ( -- )
[ user drop-table ] ignore-errors
user create-table ;
TUPLE: db-auth-provider ;
TUPLE: from-db ;
: db-auth-provider T{ db-auth-provider } ;
: from-db T{ from-db } ;
M: db-auth-provider check-login
drop
: find-user ( username -- user )
<user>
swap >>name
swap >>password
select-tuple >boolean ;
swap >>username
select-tuple ;
M: db-auth-provider new-user
M: from-db get-user
drop
find-user ;
M: from-db new-user
drop
[
<user>
swap >>name
dup select-tuple [ name>> user-exists ] when
"unassigned" >>password
insert-tuple
dup username>> find-user [
drop f
] [
dup insert-tuple
] if
] with-transaction ;
M: db-auth-provider set-password
drop
[
<user>
swap >>name
dup select-tuple [ ] [ no-such-user ] ?if
swap >>password update-tuple
] with-transaction ;
M: from-db update-user
drop update-tuple ;

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

@ -3,12 +3,14 @@
USING: http.server.auth.providers kernel ;
IN: http.server.auth.providers.null
TUPLE: null-auth-provider ;
! Named "no" because we can say no >>users
: null-auth-provider T{ null-auth-provider } ;
TUPLE: no ;
M: null-auth-provider check-login 3drop f ;
: no T{ no } ;
M: null-auth-provider new-user 3drop f ;
M: no get-user 2drop f ;
M: null-auth-provider set-password 3drop f ;
M: no new-user 2drop f ;
M: no update-user 2drop ;

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

@ -1,18 +1,56 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ;
USING: kernel new-slots accessors random math.parser locals
sequences math ;
IN: http.server.auth.providers
GENERIC: check-login ( password user provider -- ? )
TUPLE: user username realname password email ticket profile ;
GENERIC: new-user ( user provider -- )
: <user> user construct-empty H{ } clone >>profile ;
GENERIC: set-password ( password user provider -- )
GENERIC: get-user ( username provider -- user/f )
TUPLE: user-exists name ;
GENERIC: update-user ( user provider -- )
: user-exists ( name -- * ) \ user-exists construct-boa throw ;
GENERIC: new-user ( user provider -- user/f )
TUPLE: no-such-user name ;
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
: no-such-user ( name -- * ) \ no-such-user construct-boa throw ;
:: set-password ( password username provider -- )
[let | user [ username provider get-user ] |
user [
user
password >>password
provider update-user t
] [ f ] if
] ;
! Password recovery support
:: issue-ticket ( email username provider -- user/f )
[let | user [ username provider get-user ] |
user [
user email>> length 0 > [
user email>> email = [
user
random-256 >hex >>ticket
dup provider update-user
] [ f ] if
] [ f ] if
] [ f ] if
] ;
:: claim-ticket ( ticket username provider -- user/f )
[let | user [ username provider get-user ] |
user [
user ticket>> ticket = [
user f >>ticket dup provider update-user
] [ f ] if
] [ f ] if
] ;
! For configuration
: add-user ( provider user -- provider )
over new-user [ "User exists" throw ] when ;

64
extra/http/server/callbacks/callbacks-tests.factor Executable file
View File

@ -0,0 +1,64 @@
IN: http.server.callbacks
USING: http.server.actions http.server.callbacks accessors
http.server http tools.test namespaces io fry sequences
splitting kernel hashtables continuations ;
[ 123 ] [
[
<request> "GET" >>method request set
[
exit-continuation set
"xxx"
<action> [ [ "hello" print 123 ] show-final ] >>get
<callback-responder>
call-responder
] callcc1
] with-scope
] unit-test
[
<action> [
[
"hello" print
"text/html" <content> swap '[ , write ] >>body
] show-page
"byebye" print
[ 123 ] show-final
] >>get
<callback-responder> "r" set
[ 123 ] [
[
exit-continuation set
<request> "GET" >>method request set
"" "r" get call-responder
] callcc1
body>> first
<request>
"GET" >>method
swap cont-id associate >>query
"/" >>path
request set
[
exit-continuation set
"/"
"r" get call-responder
] callcc1
! get-post-get
<request>
"GET" >>method
swap "location" header "=" last-split1 nip cont-id associate >>query
"/" >>path
request set
[
exit-continuation set
"/"
"r" get call-responder
] callcc1
] unit-test
] with-scope

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

@ -3,7 +3,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: html http http.server io kernel math namespaces
continuations calendar sequences assocs new-slots hashtables
accessors arrays alarms quotations combinators ;
accessors arrays alarms quotations combinators
combinators.cleave fry ;
IN: http.server.callbacks
SYMBOL: responder
@ -21,57 +22,45 @@ TUPLE: callback cont quot expires alarm responder ;
: timeout 20 minutes ;
: timeout-callback ( callback -- )
dup alarm>> cancel-alarm
dup responder>> callbacks>> delete-at ;
[ alarm>> cancel-alarm ]
[ dup responder>> callbacks>> delete-at ]
bi ;
: touch-callback ( callback -- )
dup expires>> [
dup alarm>> [ cancel-alarm ] when*
dup [ timeout-callback ] curry timeout later >>alarm
dup '[ , timeout-callback ] timeout later >>alarm
] when drop ;
: <callback> ( cont quot expires? -- callback )
[ f responder get callback construct-boa ] keep
[ dup touch-callback ] when ;
f callback-responder get callback construct-boa
dup touch-callback ;
: invoke-callback ( request exit-cont callback -- response )
[ quot>> 3array ] keep cont>> continue-with ;
: invoke-callback ( callback -- response )
[ touch-callback ]
[ quot>> request get exit-continuation get 3array ]
[ cont>> continue-with ]
tri ;
: register-callback ( cont quot expires? -- id )
<callback>
responder get callbacks>> generate-key
[ responder get callbacks>> set-at ] keep ;
<callback> callback-responder get callbacks>> set-at-unique ;
SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: forward-to-url ( url -- * )
: forward-to-url ( url query -- * )
#! When executed inside a 'show' call, this will force a
#! HTTP 302 to occur to instruct the browser to forward to
#! the request URL.
request get swap <temporary-redirect> exit-with ;
<temporary-redirect> exit-with ;
: cont-id "factorcontid" ;
: id>url ( id -- url )
request get
swap cont-id associate >>query
request-url ;
: forward-to-id ( id -- * )
#! When executed inside a 'show' call, this will force a
#! HTTP 302 to occur to instruct the browser to forward to
#! the request URL.
id>url forward-to-url ;
f swap cont-id associate forward-to-url ;
: restore-request ( pair -- )
first3 >r exit-continuation set request set r> call ;
: resume-page ( request page responder callback -- * )
dup touch-callback
>r 2drop exit-continuation get
r> invoke-callback ;
first3 exit-continuation set request set call ;
SYMBOL: post-refresh-get?
@ -102,34 +91,27 @@ SYMBOL: current-show
[ restore-request store-current-show ] when* ;
: show-final ( quot -- * )
>r redirect-to-here store-current-show
r> call exit-with ; inline
>r redirect-to-here store-current-show r>
call exit-with ; inline
M: callback-responder call-responder
[
[
exit-continuation set
dup responder set
pick request set
pick cont-id query-param over callbacks>> at [
resume-page
] [
responder>> call-responder
"Continuation responder pages must use show-final" throw
] if*
] with-scope
] callcc1 >r 3drop r> ;
: resuming-callback ( responder request -- id )
cont-id query-param swap callbacks>> at ;
M: callback-responder call-responder ( path responder -- response )
[ callback-responder set ]
[ request get resuming-callback ] bi
[ invoke-callback ]
[ callback-responder get responder>> call-responder ] ?if ;
: show-page ( quot -- )
>r redirect-to-here store-current-show r>
[
[ ] register-callback
with-scope
exit-with
[ ] t register-callback swap call exit-with
] callcc1 restore-request ; inline
: quot-id ( quot -- id )
current-show get swap t register-callback ;
: quot-url ( quot -- url )
quot-id id>url ;
quot-id f swap cont-id associate derive-url ;

14
extra/http/server/cgi/cgi.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators
arrays io.launcher io http.server.static http.server
http accessors sequences strings math.parser ;
http accessors sequences strings math.parser fry ;
IN: http.server.cgi
: post? request get method>> "POST" = ;
@ -45,19 +45,17 @@ IN: http.server.cgi
<process>
over 1array >>command
swap cgi-variables >>environment ;
: serve-cgi ( name -- response )
<raw-response>
200 >>code
"CGI output follows" >>message
swap [
stdio get swap <cgi-process> <process-stream> [
post? [
request get post-data>> write flush
] when
swap '[
, stdio get swap <cgi-process> <process-stream> [
post? [ request get post-data>> write flush ] when
stdio get swap (stream-copy)
] with-stream
] curry >>body ;
] >>body ;
: enable-cgi ( responder -- responder )
[ serve-cgi ] "application/x-cgi-script"

88
extra/http/server/components/components-tests.factor Executable file
View File

@ -0,0 +1,88 @@
IN: http.server.components.tests
USING: http.server.components http.server.validators
namespaces tools.test kernel accessors new-slots
tuple-syntax mirrors http.server.actions ;
validation-failed? off
[ 3 ] [ "3" "n" <number> validate ] unit-test
[ 123 ] [
""
"n" <number>
123 >>default
validate
] unit-test
[ f ] [ validation-failed? get ] unit-test
[ t ] [ "3x" "n" <number> validate validation-error? ] unit-test
[ t ] [ validation-failed? get ] unit-test
[ "" ] [ "" "email" <email> validate ] unit-test
[ "slava@jedit.org" ] [ "slava@jedit.org" "email" <email> validate ] unit-test
[ "slava@jedit.org" ] [
"slava@jedit.org"
"email" <email>
t >>required
validate
] unit-test
[ t ] [
"a"
"email" <email>
t >>required
validate validation-error?
] unit-test
[ t ] [ "a" "email" <email> validate validation-error? ] unit-test
TUPLE: test-tuple text number more-text ;
: <test-tuple> test-tuple construct-empty ;
: <test-form> ( -- form )
"test" <form>
"resource:extra/http/server/components/test/form.fhtml" >>view-template
"resource:extra/http/server/components/test/form.fhtml" >>edit-template
"text" <string>
t >>required
add-field
"number" <number>
123 >>default
t >>required
0 >>min-value
10 >>max-value
add-field
"more-text" <text>
"hi" >>default
add-field ;
[ ] [ <test-tuple> <mirror> values set <test-form> view-form ] unit-test
[ ] [ <test-tuple> <mirror> values set <test-form> edit-form ] unit-test
[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
<test-tuple> from-tuple
<test-form> set-defaults
values-tuple
] unit-test
[
H{
{ "text" "fdafsa" }
{ "number" "xxx" }
{ "more-text" "" }
} params set
H{ } clone values set
[ t ] [ <test-form> (validate-form) ] unit-test
[ "fdafsa" ] [ "text" value ] unit-test
[ t ] [ "number" value validation-error? ] unit-test
] with-scope

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

@ -1,20 +1,23 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: new-slots html.elements http.server.validators
accessors namespaces kernel io farkup math.parser assocs
classes words tuples arrays sequences io.files
http.server.templating.fhtml splitting mirrors ;
USING: new-slots html.elements http.server.validators accessors
namespaces kernel io math.parser assocs classes words tuples
arrays sequences io.files http.server.templating.fhtml
http.server.actions splitting mirrors hashtables
combinators.cleave fry continuations math ;
IN: http.server.components
SYMBOL: validation-failed?
SYMBOL: components
TUPLE: component id ;
TUPLE: component id required default ;
: component ( name -- component )
dup components get at
[ ] [ "No such component: " swap append throw ] ?if ;
GENERIC: validate* ( string component -- result )
GENERIC: validate* ( value component -- result )
GENERIC: render-view* ( value component -- )
GENERIC: render-edit* ( value component -- )
GENERIC: render-error* ( reason value component -- )
@ -23,47 +26,203 @@ SYMBOL: values
: value values get at ;
: set-value values get set-at ;
: validate ( value component -- result )
'[
, ,
over empty? [
[ default>> [ v-default ] when* ]
[ required>> [ v-required ] when ]
bi
] [ validate* ] if
] [
dup validation-error?
[ validation-failed? on ] [ rethrow ] if
] recover ;
: render-view ( component -- )
dup id>> value swap render-view* ;
[ id>> value ] [ render-view* ] bi ;
: render-error ( error -- )
<span "error" =class span> write </span> ;
: render-edit ( component -- )
dup id>> value dup validation-error? [
dup reason>> swap value>> rot render-error*
[ reason>> ] [ value>> ] bi rot render-error*
] [
swap render-edit*
swap [ default>> or ] keep render-edit*
] if ;
: <component> ( id string -- component )
>r \ component construct-boa r> construct-delegate ; inline
: <component> ( id class -- component )
\ component construct-empty
swap construct-delegate
swap >>id ; inline
TUPLE: string min max ;
! Forms
TUPLE: form view-template edit-template components ;
: <form> ( id -- form )
form <component>
V{ } clone >>components ;
: add-field ( form component -- form )
dup id>> pick components>> set-at ;
: with-form ( form quot -- )
>r components>> components r> with-variable ; inline
: set-defaults ( form -- )
[
components get [
swap values get [
swap default>> or
] change-at
] assoc-each
] with-form ;
: view-form ( form -- )
dup view-template>> '[ , run-template ] with-form ;
: edit-form ( form -- )
dup edit-template>> '[ , run-template ] with-form ;
: validate-param ( id component -- )
[ [ params get at ] [ validate ] bi* ]
[ drop set-value ] 2bi ;
: (validate-form) ( form -- error? )
[
validation-failed? off
components get [ validate-param ] assoc-each
validation-failed? get
] with-form ;
: validate-form ( form -- )
(validate-form) [ validation-failed ] when ;
: blank-values H{ } clone values set ;
: from-tuple <mirror> values set ;
: values-tuple values get mirror-object ;
! ! !
! Canned components: for simple applications and prototyping
! ! !
: render-input ( value component type -- )
<input
=type
id>> [ =id ] [ =name ] bi
=value
input/> ;
! Hidden fields
TUPLE: hidden ;
: <hidden> ( component -- component )
hidden construct-delegate ;
M: hidden render-view*
2drop ;
M: hidden render-edit*
>r dup number? [ number>string ] when r>
"hidden" render-input ;
! String input fields
TUPLE: string min-length max-length ;
: <string> ( id -- component ) string <component> ;
M: string validate*
[ min>> v-min-length ] keep max>> v-max-length ;
[ v-one-line ] [
[ min-length>> [ v-min-length ] when* ]
[ max-length>> [ v-max-length ] when* ]
bi
] bi* ;
M: string render-view*
drop write ;
: render-input
<input "text" =type id>> dup =id =name =value input/> ;
M: string render-edit*
render-input ;
"text" render-input ;
M: string render-error*
render-input render-error ;
"text" render-input render-error ;
! Username fields
TUPLE: username ;
: <username> ( id -- component )
<string> username construct-delegate
2 >>min-length
20 >>max-length ;
M: username validate*
delegate validate* v-one-word ;
! E-mail fields
TUPLE: email ;
: <email> ( id -- component )
<string> email construct-delegate
5 >>min-length
60 >>max-length ;
M: email validate*
delegate validate* dup empty? [ v-email ] unless ;
! Password fields
TUPLE: password ;
: <password> ( id -- component )
<string> password construct-delegate
6 >>min-length
60 >>max-length ;
M: password validate*
delegate validate* v-one-word ;
M: password render-edit*
>r drop f r> "password" render-input ;
M: password render-error*
render-edit* render-error ;
! Number fields
TUPLE: number min-value max-value ;
: <number> ( id -- component ) number <component> ;
M: number validate*
[ v-number ] [
[ min-value>> [ v-min-value ] when* ]
[ max-value>> [ v-max-value ] when* ]
bi
] bi* ;
M: number render-view*
drop number>string write ;
M: number render-edit*
>r number>string r> "text" render-input ;
M: number render-error*
"text" render-input render-error ;
! Text areas
TUPLE: text ;
: <text> ( id -- component ) <string> text construct-delegate ;
: render-textarea
<textarea id>> dup =id =name textarea> write </textarea> ;
<textarea
id>> [ =id ] [ =name ] bi
textarea>
write
</textarea> ;
M: text render-edit*
render-textarea ;
@ -71,55 +230,11 @@ M: text render-edit*
M: text render-error*
render-textarea render-error ;
TUPLE: farkup ;
! Simple captchas
TUPLE: captcha ;
: <farkup> ( id -- component ) <text> farkup construct-delegate ;
: <captcha> ( id -- component )
<string> captcha construct-delegate ;
M: farkup render-view*
drop string-lines "\n" join convert-farkup write ;
TUPLE: number min max ;
: <number> ( id -- component ) number <component> ;
M: number validate*
>r v-number r> [ min>> v-min-value ] keep max>> v-max-value ;
M: number render-view*
drop number>string write ;
M: number render-edit*
>r number>string r> render-input ;
M: number render-error*
render-input render-error ;
: with-components ( tuple components quot -- )
[
>r components set
dup make-mirror values set
tuple set
r> call
] with-scope ; inline
TUPLE: form view-template edit-template components ;
: <form> ( id view-template edit-template -- form )
V{ } clone form construct-boa
swap \ component construct-boa
over set-delegate ;
: add-field ( form component -- form )
dup id>> pick components>> set-at ;
M: form render-view* ( value form -- )
dup components>>
swap view-template>>
[ resource-path run-template-file ] curry
with-components ;
M: form render-edit* ( value form -- )
dup components>>
swap edit-template>>
[ resource-path run-template-file ] curry
with-components ;
M: captcha validate*
drop v-captcha ;

13
extra/http/server/components/farkup/farkup.factor Executable file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: splitting http.server.components kernel io sequences
farkup ;
IN: http.server.components.farkup
TUPLE: farkup ;
: <farkup> ( id -- component )
<text> farkup construct-delegate ;
M: farkup render-view*
drop string-lines "\n" join convert-farkup write ;

1
extra/http/server/components/test/form.fhtml Executable file
View File

@ -0,0 +1 @@

72
extra/http/server/crud/crud.factor Normal file → Executable file
View File

@ -1,13 +1,69 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: http.server.crud
USING: kernel namespaces db.tuples math.parser
http.server.actions accessors ;
USING: kernel namespaces db.tuples math.parser http.server
http.server.actions http.server.components
http.server.validators accessors fry locals hashtables ;
: by-id ( class -- tuple )
construct-empty "id" get >>id ;
: <delete-action> ( class -- action )
:: <view-action> ( form ctor -- action )
<action>
{ { "id" [ string>number ] } } >>post-params
swap [ by-id delete-tuple f ] curry >>post ;
{ { "id" [ v-number ] } } >>get-params
[ "id" get ctor call select-tuple from-tuple ] >>init
[
"text/html" <content>
[ form view-form ] >>body
] >>display ;
: <id-redirect> ( id next -- response )
swap number>string "id" associate <permanent-redirect> ;
:: <create-action> ( form ctor next -- action )
<action>
[ f ctor call from-tuple form set-defaults ] >>init
[
"text/html" <content>
[ form edit-form ] >>body
] >>display
[
f ctor call from-tuple
form validate-form
values-tuple insert-tuple
"id" value next <id-redirect>
] >>submit ;
:: <edit-action> ( form ctor next -- action )
<action>
{ { "id" [ v-number ] } } >>get-params
[ "id" get ctor call select-tuple from-tuple ] >>init
[
"text/html" <content>
[ form edit-form ] >>body
] >>display
[
f ctor call from-tuple
form validate-form
values-tuple update-tuple
"id" value next <id-redirect>
] >>submit ;
:: <delete-action> ( ctor next -- action )
<action>
{ { "id" [ v-number ] } } >>post-params
[
"id" get ctor call delete-tuple
next f <permanent-redirect>
] >>submit ;

10
extra/http/server/db/db.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db http.server kernel new-slots accessors
continuations namespaces destructors ;
continuations namespaces destructors combinators.cleave ;
IN: http.server.db
TUPLE: db-persistence responder db params ;
@ -9,10 +9,8 @@ TUPLE: db-persistence responder db params ;
C: <db-persistence> db-persistence
: connect-db ( db-persistence -- )
dup db>> swap params>> make-db
dup db set
dup db-open
add-always-destructor ;
[ db>> ] [ params>> ] bi make-db
[ db set ] [ db-open ] [ add-always-destructor ] tri ;
M: db-persistence call-responder
dup connect-db responder>> call-responder ;
[ connect-db ] [ responder>> call-responder ] bi ;

34
extra/http/server/server-tests.factor
View File

@ -2,18 +2,35 @@ USING: http.server tools.test kernel namespaces accessors
new-slots io http math sequences assocs ;
IN: http.server.tests
[
<request>
"www.apple.com" >>host
"/xxx/bar" >>path
{ { "a" "b" } } >>query
request set
[ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test
[ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test
[ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test
[ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test
[ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test
[ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test
[ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test
[ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test
] with-scope
TUPLE: mock-responder path ;
C: <mock-responder> mock-responder
M: mock-responder call-responder
2nip
nip
path>> on
"text/plain" <content> ;
: check-dispatch ( tag path -- ? )
over off
<request> swap default-host get call-responder
main-responder get call-responder
write-response get ;
[
@ -24,14 +41,14 @@ M: mock-responder call-responder
"123" <mock-responder> "123" add-responder
"default" <mock-responder> >>default
"baz" add-responder
default-host set
main-responder set
[ "foo" ] [
"foo" default-host get find-responder path>> nip
"foo" main-responder get find-responder path>> nip
] unit-test
[ "bar" ] [
"bar" default-host get find-responder path>> nip
"bar" main-responder get find-responder path>> nip
] unit-test
[ t ] [ "foo" "foo" check-dispatch ] unit-test
@ -46,7 +63,8 @@ M: mock-responder call-responder
[ t ] [
<request>
"baz" >>path
"baz" default-host get call-responder
request set
"baz" main-responder get call-responder
dup code>> 300 399 between? >r
header>> "location" swap at "baz/" tail? r> and
] unit-test
@ -55,7 +73,7 @@ M: mock-responder call-responder
[
<dispatcher>
"default" <mock-responder> >>default
default-host set
main-responder set
[ "/default" ] [ "/default" default-host get find-responder drop ] unit-test
[ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
] with-scope

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

@ -4,10 +4,15 @@ USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
new-slots html.elements accessors math.parser combinators.lib
vocabs.loader debugger html continuations random combinators
destructors io.encodings.latin1 ;
destructors io.encodings.latin1 fry combinators.cleave ;
IN: http.server
GENERIC: call-responder ( request path responder -- response )
GENERIC: call-responder ( path responder -- response )
: <content> ( content-type -- response )
<response>
200 >>code
swap set-content-type ;
TUPLE: trivial-responder response ;
@ -18,16 +23,16 @@ M: trivial-responder call-responder nip response>> call ;
: trivial-response-body ( code message -- )
<html>
<body>
<h1> swap number>string write bl write </h1>
<h1> [ number>string write bl ] [ write ] bi* </h1>
</body>
</html> ;
: <trivial-response> ( code message -- response )
<response>
2over [ trivial-response-body ] 2curry >>body
"text/html" set-content-type
swap >>message
swap >>code ;
2dup '[ , , trivial-response-body ]
"text/html" <content>
swap >>body
swap >>message
swap >>code ;
: <400> ( -- response )
400 "Bad request" <trivial-response> ;
@ -37,41 +42,58 @@ M: trivial-responder call-responder nip response>> call ;
SYMBOL: 404-responder
[ drop <404> ] <trivial-responder> 404-responder set-global
[ <404> ] <trivial-responder> 404-responder set-global
: modify-for-redirect ( request to -- url )
: url-redirect ( to query -- url )
#! Different host.
dup assoc-empty? [
drop
] [
assoc>query "?" swap 3append
] if ;
: absolute-redirect ( to query -- url )
#! Same host.
request get clone
swap [ >>query ] when*
swap >>path
request-url ;
: replace-last-component ( path with -- path' )
>r "/" last-split1 drop "/" r> 3append ;
: relative-redirect ( to query -- url )
request get clone
swap [ >>query ] when*
swap [ '[ , replace-last-component ] change-path ] when*
request-url ;
: derive-url ( to query -- url )
{
{ [ dup "http://" head? ] [ nip ] }
{ [ dup "/" head? ] [ >>path request-url ] }
{ [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] }
{ [ over "http://" head? ] [ url-redirect ] }
{ [ over "/" head? ] [ absolute-redirect ] }
{ [ t ] [ relative-redirect ] }
} cond ;
: <redirect> ( request to code message -- response )
<trivial-response>
-rot modify-for-redirect
"location" set-header ;
: <redirect> ( to query code message -- response )
<trivial-response> -rot derive-url "location" set-header ;
\ <redirect> DEBUG add-input-logging
: <permanent-redirect> ( request to -- response )
: <permanent-redirect> ( to query -- response )
301 "Moved Permanently" <redirect> ;
: <temporary-redirect> ( request to -- response )
: <temporary-redirect> ( to query -- response )
307 "Temporary Redirect" <redirect> ;
: <content> ( content-type -- response )
<response>
200 >>code
swap set-content-type ;
TUPLE: dispatcher default responders ;
: <dispatcher> ( -- dispatcher )
404-responder H{ } clone dispatcher construct-boa ;
404-responder get H{ } clone dispatcher construct-boa ;
: set-main ( dispatcher name -- dispatcher )
[ <permanent-redirect> ] curry
<trivial-responder> >>default ;
'[ , f <permanent-redirect> ] <trivial-responder>
>>default ;
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
@ -80,18 +102,18 @@ TUPLE: dispatcher default responders ;
over split-path pick responders>> at*
[ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
: redirect-with-/ ( request -- response )
dup path>> "/" append <permanent-redirect> ;
: redirect-with-/ ( -- response )
request get path>> "/" append f <permanent-redirect> ;
M: dispatcher call-responder
M: dispatcher call-responder ( path dispatcher -- response )
over [
3dup find-responder call-responder [
>r 3drop r>
2dup find-responder call-responder [
2nip
] [
default>> [
call-responder
] [
3drop f
drop f
] if*
] if*
] [
@ -107,21 +129,18 @@ M: dispatcher call-responder
: <webapp> ( class -- dispatcher )
<dispatcher> swap construct-delegate ; inline
SYMBOL: virtual-hosts
SYMBOL: default-host
SYMBOL: main-responder
virtual-hosts global [ drop H{ } clone ] cache drop
default-host global [ drop 404-responder get-global ] cache drop
: find-virtual-host ( host -- responder )
virtual-hosts get at [ default-host get ] unless* ;
main-responder global
[ drop 404-responder get-global ] cache
drop
SYMBOL: development-mode
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
swap [
"Internal server error" [
swap '[
, "Internal server error" [
development-mode get [
[ print-error nl :c ] with-html-stream
] [
@ -129,27 +148,40 @@ SYMBOL: development-mode
trivial-response-body
] if
] simple-page
] curry >>body ;
] >>body ;
: do-response ( request response -- )
: do-response ( response -- )
dup write-response
swap method>> "HEAD" =
request get method>> "HEAD" =
[ drop ] [ write-response-body ] if ;
: do-request ( request -- response )
[
dup dup path>> over host>>
find-virtual-host call-responder
[ <404> ] unless*
] [ dup \ do-request log-error <500> ] recover ;
: default-timeout 1 minutes stdio get set-timeout ;
LOG: httpd-hit NOTICE
: log-request ( request -- )
{ method>> host>> path>> } map-exec-with httpd-hit ;
SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: do-request ( request -- response )
'[
exit-continuation set ,
[
[ log-request ]
[ request set ]
[ path>> main-responder get call-responder ] tri
[ <404> ] unless*
] [
[ \ do-request log-error ]
[ <500> ]
bi
] recover
] callcc1
exit-continuation off ;
: default-timeout 1 minutes stdio get set-timeout ;
: ?refresh-all ( -- )
development-mode get-global
[ global [ refresh-all ] bind ] when ;
@ -159,8 +191,8 @@ LOG: httpd-hit NOTICE
default-timeout
?refresh-all
read-request
dup log-request
do-request do-response
do-request
do-response
] with-destructors ;
: httpd ( port -- )
@ -171,6 +203,10 @@ LOG: httpd-hit NOTICE
MAIN: httpd-main
! Utility
: generate-key ( assoc -- str )
4 big-random >hex dup pick key?
[ drop generate-key ] [ nip ] if ;
>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 ;

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

@ -8,9 +8,9 @@ TUPLE: foo ;
C: <foo> foo
M: foo init-session drop 0 "x" sset ;
M: foo init-session* drop 0 "x" sset ;
"1234" f <session> [
f <session> [
[ ] [ 3 "x" sset ] unit-test
[ 9 ] [ "x" sget sq ] unit-test

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

@ -2,16 +2,16 @@
! 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
quotations hashtables sequences ;
quotations hashtables sequences fry combinators.cleave ;
IN: http.server.sessions
! ! ! ! ! !
! WARNING: this session manager is vulnerable to XSRF attacks
! ! ! ! ! !
GENERIC: init-session ( responder -- )
GENERIC: init-session* ( responder -- )
M: dispatcher init-session drop ;
M: dispatcher init-session* drop ;
TUPLE: session-manager responder sessions ;
@ -19,10 +19,10 @@ TUPLE: session-manager responder sessions ;
>r H{ } clone session-manager construct-boa r>
construct-delegate ; inline
TUPLE: session id manager namespace alarm ;
TUPLE: session manager id namespace alarm ;
: <session> ( id manager -- session )
H{ } clone <box> \ session construct-boa ;
: <session> ( manager -- session )
f H{ } clone <box> \ session construct-boa ;
: timeout ( -- dt ) 20 minutes ;
@ -30,13 +30,15 @@ TUPLE: session id manager namespace alarm ;
alarm>> [ cancel-alarm ] if-box? ;
: delete-session ( session -- )
dup cancel-timeout
dup manager>> sessions>> delete-at ;
[ cancel-timeout ]
[ dup manager>> sessions>> delete-at ]
bi ;
: touch-session ( session -- )
dup cancel-timeout
dup [ delete-session ] curry timeout later
swap session-alarm >box ;
: touch-session ( session -- session )
[ cancel-timeout ]
[ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
[ ]
tri ;
: session ( -- assoc ) \ session get namespace>> ;
@ -46,20 +48,20 @@ TUPLE: session id manager namespace alarm ;
: schange ( key quot -- ) session swap change-at ; inline
: init-session ( session -- session )
dup dup \ session [
manager>> responder>> init-session*
] with-variable ;
: new-session ( responder -- id )
[ sessions>> generate-key dup ] keep
[ <session> dup touch-session ] keep
[ swap \ session [ responder>> init-session ] with-variable ] 2keep
>r over r> sessions>> set-at ;
[ <session> init-session touch-session ]
[ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
bi id>> ;
: get-session ( id responder -- session )
sessions>> tuck at* [
nip dup touch-session
] [
2drop f
] if ;
: get-session ( id responder -- session/f )
sessions>> at* [ touch-session ] when ;
: call-responder/session ( request path responder session -- response )
: call-responder/session ( path responder session -- response )
\ session set responder>> call-responder ;
: sessions ( -- manager/f )
@ -71,6 +73,14 @@ M: object session-link* 2drop url-encode ;
: session-link ( url query -- string ) sessions session-link* ;
TUPLE: null-sessions ;
: <null-sessions>
null-sessions <session-manager> ;
M: null-sessions call-responder ( path responder -- response )
dup <session> call-responder/session ;
TUPLE: url-sessions ;
: <url-sessions> ( responder -- responder' )
@ -78,18 +88,21 @@ TUPLE: url-sessions ;
: sess-id "factorsessid" ;
M: url-sessions call-responder ( request path responder -- response )
pick sess-id query-param over get-session [
: current-session ( responder request -- session )
sess-id query-param swap get-session ;
M: url-sessions call-responder ( path responder -- response )
dup request get current-session [
call-responder/session
] [
new-session nip sess-id set-query-param
dup request-url <temporary-redirect>
nip
f swap new-session sess-id associate <temporary-redirect>
] if* ;
M: url-sessions session-link*
drop
url-encode
\ session get id>> sess-id associate union assoc>query
>r url-encode r>
dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
TUPLE: cookie-sessions ;
@ -97,15 +110,15 @@ TUPLE: cookie-sessions ;
: <cookie-sessions> ( responder -- responder' )
cookie-sessions <session-manager> ;
: get-session-cookie ( request responder -- cookie )
>r sess-id get-cookie dup
[ value>> r> get-session ] [ r> 2drop f ] if ;
: get-session-cookie ( responder -- cookie )
request get sess-id get-cookie
[ value>> swap get-session ] [ drop f ] if* ;
: <session-cookie> ( id -- cookie )
sess-id <cookie> ;
M: cookie-sessions call-responder ( request path responder -- response )
3dup nip get-session-cookie [
M: cookie-sessions call-responder ( path responder -- response )
dup get-session-cookie [
call-responder/session
] [
dup new-session

49
extra/http/server/static/static.factor
View File

@ -3,7 +3,8 @@
USING: calendar html io io.files kernel math math.parser http
http.server namespaces parser sequences strings assocs
hashtables debugger http.mime sorting html.elements logging
calendar.format new-slots accessors io.encodings.binary ;
calendar.format new-slots accessors io.encodings.binary
combinators.cleave fry ;
IN: http.server.static
SYMBOL: responder
@ -31,21 +32,23 @@ TUPLE: file-responder root hook special ;
: <static> ( root -- responder )
[
<content>
over file-length "content-length" set-header
over file-http-date "last-modified" set-header
swap [ binary <file-reader> stdio get stream-copy ] curry >>body
swap
[ file-length "content-length" set-header ]
[ file-http-date "last-modified" set-header ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
tri
] <file-responder> ;
: serve-static ( filename mime-type -- response )
over last-modified-matches?
[ 2drop <304> ] [ responder get hook>> call ] if ;
[ 2drop <304> ] [ file-responder get hook>> call ] if ;
: serving-path ( filename -- filename )
"" or responder get root>> swap path+ ;
"" or file-responder get root>> swap path+ ;
: serve-file ( filename -- response )
dup mime-type
dup responder get special>> at
dup file-responder get special>> at
[ call ] [ serve-static ] ?if ;
\ serve-file NOTICE add-input-logging
@ -56,21 +59,22 @@ TUPLE: file-responder root hook special ;
: directory. ( path -- )
dup file-name [
<h1> dup file-name write </h1>
<ul>
directory sort-keys
[ <li> file. </li> ] assoc-each
</ul>
[ <h1> file-name write </h1> ]
[
<ul>
directory sort-keys
[ <li> file. </li> ] assoc-each
</ul>
] bi
] simple-html-document ;
: list-directory ( directory -- response )
"text/html" <content>
swap [ directory. ] curry >>body ;
swap '[ , directory. ] >>body ;
: find-index ( filename -- path )
{ "index.html" "index.fhtml" }
[ dupd path+ exists? ] find nip
dup [ path+ ] [ nip ] if ;
{ "index.html" "index.fhtml" } [ path+ ] with map
[ exists? ] find nip ;
: serve-directory ( filename -- response )
dup "/" tail? [
@ -87,15 +91,14 @@ TUPLE: file-responder root hook special ;
drop <404>
] if ;
M: file-responder call-responder ( request path responder -- response )
over [
".." pick subseq? [
3drop <400>
M: file-responder call-responder ( path responder -- response )
file-responder set
dup [
".." over subseq? [
drop <400>
] [
responder set
swap request set
serve-object
] if
] [
2drop redirect-with-/
drop redirect-with-/
] if ;

8
extra/http/server/templating/fhtml/fhtml-tests.factor
View File

@ -4,12 +4,12 @@ parser ;
IN: http.server.templating.fhtml.tests
: test-template ( path -- ? )
"extra/http/server/templating/fhtml/test/" swap append
"resource:extra/http/server/templating/fhtml/test/"
swap append
[
".fhtml" append resource-path
[ run-template-file ] with-string-writer
".fhtml" append [ run-template ] with-string-writer
] keep
".html" append resource-path utf8 file-contents = ;
".html" append ?resource-path utf8 file-contents = ;
[ t ] [ "example" test-template ] unit-test
[ t ] [ "bug" test-template ] unit-test

33
extra/http/server/templating/fhtml/fhtml.factor
View File

@ -2,10 +2,10 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel parser namespaces io
io.files io.streams.string html html.elements
source-files debugger combinators math quotations generic
strings splitting accessors http.server.static http.server
assocs io.encodings.utf8 ;
io.files io.streams.string html html.elements source-files
debugger combinators math quotations generic strings splitting
accessors http.server.static http.server assocs
io.encodings.utf8 fry ;
IN: http.server.templating.fhtml
@ -75,9 +75,9 @@ DEFER: <% delimiter
: html-error. ( error -- )
<pre> error. </pre> ;
: run-template-file ( filename -- )
[
[
: run-template ( filename -- )
'[
, [
"quiet" on
parser-notes off
templating-vocab use+
@ -86,21 +86,18 @@ DEFER: <% delimiter
?resource-path utf8 file-contents
[ eval-template ] [ html-error. drop ] recover
] with-file-vocabs
] curry assert-depth ;
: run-relative-template-file ( filename -- )
file get source-file-path parent-directory
swap path+ run-template-file ;
] assert-depth ;
: template-convert ( infile outfile -- )
utf8 [ run-template-file ] with-file-writer ;
utf8 [ run-template ] with-file-writer ;
! responder integration
: serve-template ( name -- response )
"text/html" <content>
swap '[ , run-template ] >>body ;
! file responder integration
: serve-fhtml ( filename -- response )
"text/html" <content>
swap [ run-template-file ] curry >>body ;
: enable-fhtml ( responder -- responder )
[ serve-fhtml ]
[ serve-template ]
"application/x-factor-server-page"
pick special>> set-at ;

22
extra/http/server/validators/validators-tests.factor Normal file → Executable file
View File

@ -1,4 +1,22 @@
IN: http.server.validators.tests
USING: kernel sequences tools.test http.server.validators ;
USING: kernel sequences tools.test http.server.validators
accessors ;
[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test
[ "foo" v-number ] [ validation-error? ] must-fail-with
[ "slava@factorcode.org" ] [
"slava@factorcode.org" v-email
] unit-test
[ "slava+foo@factorcode.org" ] [
"slava+foo@factorcode.org" v-email
] unit-test
[ "slava@factorcode.o" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with
[ "sla@@factorcode.o" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with
[ "slava@factorcodeorg" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with

39
extra/http/server/validators/validators.factor Normal file → Executable file
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces
math.parser assocs new-slots ;
math.parser assocs new-slots regexp fry unicode.categories
combinators.cleave sequences ;
IN: http.server.validators
TUPLE: validation-error value reason ;
@ -9,17 +10,6 @@ TUPLE: validation-error value reason ;
: validation-error ( value reason -- * )
\ validation-error construct-boa throw ;
: with-validator ( string quot -- result error? )
[ f ] compose curry
[ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline
: validate-param ( name validator assoc -- error? )
swap pick
>r >r at r> with-validator swap r> set ;
: validate-params ( validators assoc -- error? )
[ validate-param ] curry { } assoc>map [ ] contains? ;
: v-default ( str def -- str )
over empty? spin ? ;
@ -47,7 +37,7 @@ TUPLE: validation-error value reason ;
"must be a number" validation-error
] ?if ;
: v-min-value ( str n -- str )
: v-min-value ( x n -- x )
2dup < [
[ "must be at least " % # ] "" make
validation-error
@ -55,10 +45,31 @@ TUPLE: validation-error value reason ;
drop
] if ;
: v-max-value ( str n -- str )
: v-max-value ( x n -- x )
2dup > [
[ "must be no more than " % # ] "" make
validation-error
] [
drop
] if ;
: v-regexp ( str what regexp -- str )
>r over r> matches?
[ drop ] [ "invalid " swap append validation-error ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
"e-mail"
R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i
v-regexp ;
: v-captcha ( str -- str )
dup empty? [ "must remain blank" validation-error ] unless ;
: v-one-line ( str -- str )
dup "\r\n" seq-intersect empty?
[ "must be a single line" validation-error ] unless ;
: v-one-word ( str -- str )
dup [ alpha? ] all?
[ "must be a single word" validation-error ] unless ;

11
extra/logging/insomniac/insomniac-docs.factor
View File

@ -2,12 +2,6 @@ USING: help.markup help.syntax assocs strings logging
logging.analysis smtp ;
IN: logging.insomniac
HELP: insomniac-smtp-host
{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ;
HELP: insomniac-smtp-port
{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ;
HELP: insomniac-sender
{ $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
@ -21,7 +15,7 @@ HELP: ?analyze-log
HELP: email-log-report
{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } }
{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
{ $description "E-mails a log report for the given log service. The " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
HELP: schedule-insomniac
{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
@ -33,9 +27,6 @@ $nl
"Required configuration parameters:"
{ $subsection insomniac-sender }
{ $subsection insomniac-recipients }
"Optional configuration parameters:"
{ $subsection insomniac-smtp-host }
{ $subsection insomniac-smtp-port }
"E-mailing a one-off report:"
{ $subsection email-log-report }
"E-mailing reports and rotating logs on a daily basis:"

27
extra/logging/insomniac/insomniac.factor
View File

@ -6,8 +6,6 @@ io.encodings.utf8 accessors calendar qualified ;
QUALIFIED: io.sockets
IN: logging.insomniac
SYMBOL: insomniac-smtp-host
SYMBOL: insomniac-smtp-port
SYMBOL: insomniac-sender
SYMBOL: insomniac-recipients
@ -18,29 +16,20 @@ SYMBOL: insomniac-recipients
r> 2drop f
] if ;
: with-insomniac-smtp ( quot -- )
[
insomniac-smtp-host get [ smtp-host set ] when*
insomniac-smtp-port get [ smtp-port set ] when*
call
] with-scope ; inline
: email-subject ( service -- string )
[
"[INSOMNIAC] " % % " on " % io.sockets:host-name %
] "" make ;
: (email-log-report) ( service word-names -- )
[
dupd ?analyze-log dup [
<email>
swap >>body
insomniac-recipients get >>to
insomniac-sender get >>from
swap email-subject >>subject
send
] [ 2drop ] if
] with-insomniac-smtp ;
dupd ?analyze-log dup [
<email>
swap >>body
insomniac-recipients get >>to
insomniac-sender get >>from
swap email-subject >>subject
send-email
] [ 2drop ] if ;
\ (email-log-report) NOTICE add-error-logging

4
extra/regexp/regexp-tests.factor
View File

@ -222,3 +222,7 @@ IN: regexp-tests
[ f ] [ "foo bar" "foo\\B bar" f <regexp> matches? ] unit-test
[ t ] [ "fooxbar" "foo\\Bxbar" f <regexp> matches? ] unit-test
[ f ] [ "foo" "foo\\Bbar" f <regexp> matches? ] unit-test
[ t ] [ "s@f" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
[ t ] [ ".o" "\\.[a-z]" f <regexp> matches? ] unit-test

3
extra/regexp/regexp.factor
View File

@ -167,7 +167,8 @@ C: <group-result> group-result
"(" ")" surrounded-by ;
: 'range' ( -- parser )
any-char-parser "-" token <& any-char-parser <&>
[ CHAR: ] = not ] satisfy "-" token <&
[ CHAR: ] = not ] satisfy <&>
[ first2 char-between?-quot ] <@ ;
: 'character-class-term' ( -- parser )

2
extra/singleton/singleton.factor Normal file → Executable file
View File

@ -5,7 +5,7 @@ sequences words ;
IN: singleton
: define-singleton ( token -- )
\ word swap in get create-class
\ word swap create-class-in
dup [ eq? ] curry define-predicate-class ;
: SINGLETON:

4
extra/smtp/server/server.factor
View File

@ -6,7 +6,7 @@ IN: smtp.server
! Mock SMTP server for testing purposes.
! Usage: 4321 smtp-server
! Usage: 4321 mock-smtp-server
! $ telnet 127.0.0.1 4321
! Trying 127.0.0.1...
! Connected to localhost.
@ -61,7 +61,7 @@ SYMBOL: data-mode
] }
} cond nip [ process ] when ;
: smtp-server ( port -- )
: mock-smtp-server ( port -- )
"Starting SMTP server on port " write dup . flush
"127.0.0.1" swap <inet4> ascii <server> [
accept [

9
extra/smtp/smtp-tests.factor
View File

@ -1,4 +1,4 @@
USING: smtp tools.test io.streams.string threads
USING: smtp tools.test io.streams.string io.sockets threads
smtp.server kernel sequences namespaces logging accessors
assocs sorting ;
IN: smtp.tests
@ -62,12 +62,11 @@ IN: smtp.tests
rot from>>
] unit-test
[ ] [ [ 4321 smtp-server ] in-thread ] unit-test
[ ] [ [ 4321 mock-smtp-server ] in-thread ] unit-test
[ ] [
[
"localhost" smtp-host set
4321 smtp-port set
"localhost" 4321 <inet> smtp-server set
<email>
"Hi guys\nBye guys" >>body
@ -77,6 +76,6 @@ IN: smtp.tests
"Ed <dharmatech@factorcode.org>"
} >>to
"Doug <erg@factorcode.org>" >>from
send
send-email
] with-scope
] unit-test

23
extra/smtp/smtp.factor
View File

@ -8,19 +8,16 @@ calendar.format new-slots accessors ;
IN: smtp
SYMBOL: smtp-domain
SYMBOL: smtp-host "localhost" smtp-host set-global
SYMBOL: smtp-port 25 smtp-port set-global
SYMBOL: smtp-server "localhost" 25 <inet> smtp-server set-global
SYMBOL: read-timeout 1 minutes read-timeout set-global
SYMBOL: esmtp t esmtp set-global
: log-smtp-connection ( host port -- ) 2drop ;
\ log-smtp-connection NOTICE add-input-logging
LOG: log-smtp-connection NOTICE ( addrspec -- )
: with-smtp-connection ( quot -- )
smtp-host get smtp-port get
2dup log-smtp-connection
<inet> ascii <client> [
smtp-server get
dup log-smtp-connection
ascii <client> [
smtp-domain [ host-name or ] change
read-timeout get stdio get set-timeout
call
@ -33,8 +30,8 @@ SYMBOL: esmtp t esmtp set-global
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
dup [ "\r\n>" member? ] contains?
[ "Bad e-mail address: " swap append throw ] when ;
dup "\r\n>" seq-intersect empty?
[ "Bad e-mail address: " swap append throw ] unless ;
: mail-from ( fromaddr -- )
"MAIL FROM:<" write validate-address write ">" write crlf ;
@ -91,8 +88,8 @@ LOG: smtp-response DEBUG
: get-ok ( -- ) flush receive-response check-response ;
: validate-header ( string -- string' )
dup [ "\r\n" member? ] contains?
[ "Invalid header string: " swap append throw ] when ;
dup "\r\n" seq-intersect empty?
[ "Invalid header string: " swap append throw ] unless ;
: write-header ( key value -- )
swap
@ -153,7 +150,7 @@ M: email clone
email construct-empty
H{ } clone >>headers ;
: send ( email -- )
: send-email ( email -- )
prepare (send) ;
! Dirk's old AUTH CRAM-MD5 code. I don't know anything about

2
extra/ui/tools/tools.factor
View File

@ -66,7 +66,7 @@ workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener }
{ T{ key-down f { A+ } "2" } com-browser }
{ T{ key-down f { A+ } "3" } com-inspector }
{ T{ key-down f { A+ } "5" } com-profiler }
{ T{ key-down f { A+ } "4" } com-profiler }
} define-command-map
\ workspace-window

2
extra/units/units-tests.factor Normal file → Executable file
View File

@ -20,4 +20,4 @@ IN: units.tests
: km/L km 1 L d/ ;
: mpg miles 1 gallons d/ ;
[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
! [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test

3
extra/units/units.factor
View File

@ -12,9 +12,6 @@ TUPLE: dimensions-not-equal ;
M: dimensions-not-equal summary drop "Dimensions do not match" ;
: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
swap [ member? ] curry subset ;
: remove-one ( seq obj -- seq )
1array split1 append ;

13
extra/xmode/code2html/code2html.factor
View File

@ -1,5 +1,6 @@
USING: xmode.tokens xmode.marker xmode.catalog kernel html html.elements io
io.files sequences words io.encodings.utf8 ;
USING: xmode.tokens xmode.marker xmode.catalog kernel html
html.elements io io.files sequences words io.encodings.utf8
namespaces ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- )
@ -40,5 +41,9 @@ IN: xmode.code2html
</html> ;
: htmlize-file ( path -- )
dup utf8 <file-reader> over ".html" append utf8 <file-writer>
[ htmlize-stream ] with-stream ;
dup utf8 [
stdio get
over ".html" append utf8 [
htmlize-stream
] with-file-writer
] with-file-reader ;

20
extra/xmode/code2html/responder/responder.factor
View File

@ -1,15 +1,21 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files namespaces http.server http.server.static http
xmode.code2html kernel html sequences accessors ;
USING: io.files io.encodings.utf8 namespaces http.server
http.server.static http xmode.code2html kernel html sequences
accessors fry combinators.cleave ;
IN: xmode.code2html.responder
: <sources> ( root -- responder )
[
drop
"text/html" <content>
over file-http-date "last-modified" set-header
swap [
dup file-name swap <file-reader> htmlize-stream
] curry >>body
"text/html" <content> swap
[ file-http-date "last-modified" set-header ]
[
'[
,
dup file-name swap utf8
<file-reader>
[ htmlize-stream ] with-html-stream
] >>body
] bi
] <file-responder> ;