diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index cc84084258..81c9b68668 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -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 [
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 7208e05af0..9fc5264440 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -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 ;
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
old mode 100644
new mode 100755
index c6230ebe16..6416e27eaf
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -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 ;
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
old mode 100644
new mode 100755
index 68f525ec6c..da96e51dd4
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -164,7 +164,7 @@ SYMBOL: builder-recipients
builder-recipients get >>to
subject >>subject
"./report" file>string >>body
- send ;
+ send-email ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index d14ec13ff8..1e3a9655a2 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -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
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index d584632609..b48c87f0ca 100755
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -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
\ No newline at end of file
+ ! PQgetlength PQgetisnull
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 2c234ec419..26b6cbe75c 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -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 )
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index d62bd43483..dbada854fb 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -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 ]
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 5913f053da..2d873aaa22 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -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 ;
diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor
index f8d49af163..490ce992ab 100755
--- a/extra/fry/fry.factor
+++ b/extra/fry/fry.factor
@@ -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 ;
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index 0d733ba97d..ee0d5f7f3b 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -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>
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 16be0d026d..66182b10ae 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -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
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 849b9e2fc9..c72a631d16 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -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
diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor
old mode 100644
new mode 100755
index 13089ae6e8..98a92e083a
--- a/extra/http/server/actions/actions-tests.factor
+++ b/extra/http/server/actions/actions-tests.factor
@@ -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
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index 5e5b7a9563..bab55eef0c 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -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* ;
diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor
new file mode 100755
index 0000000000..a9645693fb
--- /dev/null
+++ b/extra/http/server/auth/auth.factor
@@ -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>> ;
diff --git a/extra/http/server/auth/login/login-tests.factor b/extra/http/server/auth/login/login-tests.factor
new file mode 100755
index 0000000000..b69630a930
--- /dev/null
+++ b/extra/http/server/auth/login/login-tests.factor
@@ -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
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index e2f9a3608a..7d92c727c6 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -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? ;
diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml
index 9bb1438588..8e879420a9 100755
--- a/extra/http/server/auth/login/login.fhtml
+++ b/extra/http/server/auth/login/login.fhtml
@@ -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>
diff --git a/extra/http/server/auth/login/recover-1.fhtml b/extra/http/server/auth/login/recover-1.fhtml
new file mode 100755
index 0000000000..3e8448f64b
--- /dev/null
+++ b/extra/http/server/auth/login/recover-1.fhtml
@@ -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>
diff --git a/extra/http/server/auth/login/recover-2.fhtml b/extra/http/server/auth/login/recover-2.fhtml
new file mode 100755
index 0000000000..9b13734273
--- /dev/null
+++ b/extra/http/server/auth/login/recover-2.fhtml
@@ -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>
diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml
new file mode 100755
index 0000000000..b220cc4f75
--- /dev/null
+++ b/extra/http/server/auth/login/recover-3.fhtml
@@ -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>
diff --git a/extra/http/server/auth/login/recover-4.fhtml b/extra/http/server/auth/login/recover-4.fhtml
new file mode 100755
index 0000000000..dec7a5404f
--- /dev/null
+++ b/extra/http/server/auth/login/recover-4.fhtml
@@ -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>
diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml
new file mode 100755
index 0000000000..c7e274e626
--- /dev/null
+++ b/extra/http/server/auth/login/register.fhtml
@@ -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>
diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor
index 3270fe06e3..12c799816d 100755
--- a/extra/http/server/auth/providers/assoc/assoc-tests.factor
+++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor
@@ -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
diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor
index d57be622c7..8433e54fda 100755
--- a/extra/http/server/auth/providers/assoc/assoc.factor
+++ b/extra/http/server/auth/providers/assoc/assoc.factor
@@ -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 ;
diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor
index c4682c2051..247359aea4 100755
--- a/extra/http/server/auth/providers/db/db-tests.factor
+++ b/extra/http/server/auth/providers/db/db-tests.factor
@@ -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
diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor
index 9583122875..e9e79ff82f 100755
--- a/extra/http/server/auth/providers/db/db.factor
+++ b/extra/http/server/auth/providers/db/db.factor
@@ -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 ;
diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor
index 702111972e..7b8bfc627c 100755
--- a/extra/http/server/auth/providers/null/null.factor
+++ b/extra/http/server/auth/providers/null/null.factor
@@ -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 ;
diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor
index 1e0fd33a67..08b71432cd 100755
--- a/extra/http/server/auth/providers/providers.factor
+++ b/extra/http/server/auth/providers/providers.factor
@@ -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 ;
diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor
new file mode 100755
index 0000000000..4397ee5d15
--- /dev/null
+++ b/extra/http/server/callbacks/callbacks-tests.factor
@@ -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
diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor
index fd2e8f8ad7..ac03e0efc8 100755
--- a/extra/http/server/callbacks/callbacks.factor
+++ b/extra/http/server/callbacks/callbacks.factor
@@ -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 ;
diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor
index cce3e5402d..509943faa8 100755
--- a/extra/http/server/cgi/cgi.factor
+++ b/extra/http/server/cgi/cgi.factor
@@ -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"
diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor
new file mode 100755
index 0000000000..2a507e6416
--- /dev/null
+++ b/extra/http/server/components/components-tests.factor
@@ -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
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index f14b766910..bb0fc4b3dd 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -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 ;
diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor
new file mode 100755
index 0000000000..09c8471905
--- /dev/null
+++ b/extra/http/server/components/farkup/farkup.factor
@@ -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 ;
diff --git a/extra/http/server/components/test/form.fhtml b/extra/http/server/components/test/form.fhtml
new file mode 100755
index 0000000000..d3f5a12faa
--- /dev/null
+++ b/extra/http/server/components/test/form.fhtml
@@ -0,0 +1 @@
+
diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor
old mode 100644
new mode 100755
index 099ded2f7f..4893977f76
--- a/extra/http/server/crud/crud.factor
+++ b/extra/http/server/crud/crud.factor
@@ -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 ;
diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor
index 511921ce06..4a2315b4fd 100755
--- a/extra/http/server/db/db.factor
+++ b/extra/http/server/db/db.factor
@@ -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 ;
diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor
index 0635e1f895..e992a1b6fa 100755
--- a/extra/http/server/server-tests.factor
+++ b/extra/http/server/server-tests.factor
@@ -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
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 133783114d..37f21278df 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -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 ;
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index d771737c73..5c2d3a57cd 100755
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -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
diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor
index d7fed6bb64..1d90a32faf 100755
--- a/extra/http/server/sessions/sessions.factor
+++ b/extra/http/server/sessions/sessions.factor
@@ -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
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index 93eb51ce4e..6c365ad87b 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -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 ;
diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor
index e655bf9001..9774e4c1f2 100755
--- a/extra/http/server/templating/fhtml/fhtml-tests.factor
+++ b/extra/http/server/templating/fhtml/fhtml-tests.factor
@@ -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
diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor
index 3dcd23b99f..8567524217 100755
--- a/extra/http/server/templating/fhtml/fhtml.factor
+++ b/extra/http/server/templating/fhtml/fhtml.factor
@@ -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 ;
diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor
old mode 100644
new mode 100755
index ff68dcfc64..3ef2b6c863
--- a/extra/http/server/validators/validators-tests.factor
+++ b/extra/http/server/validators/validators-tests.factor
@@ -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
diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor
old mode 100644
new mode 100755
index 03beb8c3ff..7eb5163d33
--- a/extra/http/server/validators/validators.factor
+++ b/extra/http/server/validators/validators.factor
@@ -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 ;
diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor
index 93485e4c7c..7529c3ba63 100755
--- a/extra/logging/insomniac/insomniac-docs.factor
+++ b/extra/logging/insomniac/insomniac-docs.factor
@@ -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:"
diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor
index dfd7f430d2..c7d1faf42e 100755
--- a/extra/logging/insomniac/insomniac.factor
+++ b/extra/logging/insomniac/insomniac.factor
@@ -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
diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor
index f6e7c05910..5a6b0bdfac 100755
--- a/extra/regexp/regexp-tests.factor
+++ b/extra/regexp/regexp-tests.factor
@@ -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
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index fe1d87d9e9..8a642a8692 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -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 )
diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor
old mode 100644
new mode 100755
index 1451283f23..0b77443a50
--- a/extra/singleton/singleton.factor
+++ b/extra/singleton/singleton.factor
@@ -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:
diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor
index 92b605e91c..14957ceca2 100755
--- a/extra/smtp/server/server.factor
+++ b/extra/smtp/server/server.factor
@@ -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 [
diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor
index 76ceaceea4..a705a9609e 100755
--- a/extra/smtp/smtp-tests.factor
+++ b/extra/smtp/smtp-tests.factor
@@ -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
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index b23d5e3798..a941b14a47 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -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
diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor
index 062bcf9416..b98b1dba28 100755
--- a/extra/ui/tools/tools.factor
+++ b/extra/ui/tools/tools.factor
@@ -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
diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor
old mode 100644
new mode 100755
index 81f3163a77..9f0e704157
--- a/extra/units/units-tests.factor
+++ b/extra/units/units-tests.factor
@@ -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
diff --git a/extra/units/units.factor b/extra/units/units.factor
index f7aad72545..13d0a5d1cf 100755
--- a/extra/units/units.factor
+++ b/extra/units/units.factor
@@ -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 ;
diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor
index 47e619cc00..a13e412afe 100755
--- a/extra/xmode/code2html/code2html.factor
+++ b/extra/xmode/code2html/code2html.factor
@@ -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 ;
diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor
index d14ffd93b3..379f6d6c94 100755
--- a/extra/xmode/code2html/responder/responder.factor
+++ b/extra/xmode/code2html/responder/responder.factor
@@ -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> ;