From 718adfd81e79f8a3e622a572384b71478837ac42 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 9 Mar 2008 06:54:53 -0500 Subject: [PATCH 01/15] Comment out units unit test at Dan's request --- extra/units/units-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/units/units-tests.factor 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 From 563565d76df177cd8dfa61b49a3b723ea4f1d3b8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 10 Mar 2008 17:00:28 -0500 Subject: [PATCH 02/15] postgresql almost works with blobs --- extra/db/postgresql/ffi/ffi.factor | 3 +- extra/db/postgresql/lib/lib.factor | 57 ++++++++++++++++++--------- extra/db/postgresql/postgresql.factor | 18 ++++++--- extra/db/tuples/tuples-tests.factor | 9 +++-- 4 files changed, 59 insertions(+), 28 deletions(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index d14ec13ff8..a41e68234e 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 ) ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index d584632609..7f1e50f54a 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -3,7 +3,7 @@ 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 ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -44,27 +44,46 @@ IN: db.postgresql.lib [ 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 ; + [ number>string* dup [ malloc-char-string ] when ] map + [ + [ + >c-void*-array f f 0 PQexecParams + dup postgresql-result-ok? [ + dup postgresql-result-error-message swap PQclear throw + ] unless + ] keep + ] [ [ free ] each ] [ ] cleanup ; + +: pq-get-string ( handle row column -- obj ) + 3dup PQgetvalue alien>char-string + dup "" = [ >r PQgetisnull 1 = f r> ? ] [ 3nip ] if ; + +: pq-get-number ( handle row column -- obj ) + pq-get-string dup [ string>number ] when ; + +: pq-get-blob ( handle row column -- obj/f ) + [ PQgetvalue ] 3keep PQgetlength + dup 0 > [ + memory>byte-array + ] [ + 2drop f + ] 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 ] } [ 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 ( 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/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 5913f053da..094425841c 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -3,7 +3,7 @@ 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 ; @@ -161,12 +161,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 ( -- ) From 69f213fdce00ff39accc4d3bee01fe9a851d464a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Mar 2008 00:05:22 -0500 Subject: [PATCH 03/15] postgresql can store binary blobs! --- extra/db/postgresql/ffi/ffi.factor | 24 +++++- extra/db/postgresql/lib/lib.factor | 119 +++++++++++++++++++++++----- extra/db/tuples/tuples-tests.factor | 4 +- 3 files changed, 124 insertions(+), 23 deletions(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index a41e68234e..1e3a9655a2 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -298,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, @@ -347,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 7f1e50f54a..0bc7eef20c 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 libc shuffle calendar.format ; +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,34 +41,111 @@ IN: db.postgresql.lib dup postgresql-result-error-message swap PQclear throw ] unless ; -: 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* dup [ malloc-char-string ] when ] map +: 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 [ - [ - >c-void*-array f f 0 PQexecParams - dup postgresql-result-ok? [ - dup postgresql-result-error-message swap PQclear throw - ] unless - ] keep - ] [ [ free ] each ] [ ] cleanup ; + 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 ] + [ 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 PQgetisnull 1 = f r> ? ] [ 3nip ] if ; + 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 + +M: postgresql-malloc-destructor dispose ( obj -- ) + alien>> PQfreemem ; + +: postgresql-free-always ( alien -- ) + add-always-destructor ; + : pq-get-blob ( handle row column -- obj/f ) - [ PQgetvalue ] 3keep PQgetlength + [ PQgetvalue ] 3keep 3dup PQgetlength dup 0 > [ - memory>byte-array + 3nip + [ + memory>byte-array >string + 0 + [ + PQunescapeBytea dup zero? [ + postgresql-result-error-message throw + ] [ + dup postgresql-free-always + ] if + ] keep + *uint memory>byte-array + ] with-destructors ] [ - 2drop f + drop pq-get-is-null nip [ f ] [ B{ } clone ] if ] if ; : postgresql-column-typed ( handle row column type -- obj ) @@ -83,7 +162,9 @@ IN: db.postgresql.lib { 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 ] } + { FACTOR-BLOB [ + pq-get-blob + binary [ deserialize ] with-byte-reader ] } [ no-sql-type ] } case ; ! PQgetlength PQgetisnull diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 094425841c..34150f4d85 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -164,8 +164,8 @@ TUPLE: annotation n paste-id summary author mode contents ; : 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-sqlite +! [ assigned-person-schema test-tuples ] test-sqlite [ native-person-schema test-tuples ] test-postgresql [ assigned-person-schema test-tuples ] test-postgresql From a5843a360cdd1bbd416e297c0a9c03827143af35 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Mar 2008 00:09:49 -0500 Subject: [PATCH 04/15] fix a bug that a unit test found --- extra/db/postgresql/lib/lib.factor | 2 +- extra/db/tuples/tuples-tests.factor | 41 ++++++++++++++++++++++------- 2 files changed, 33 insertions(+), 10 deletions(-) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 0bc7eef20c..b48c87f0ca 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) { BLOB [ pq-get-blob ] } { FACTOR-BLOB [ pq-get-blob - binary [ deserialize ] with-byte-reader ] } + dup [ binary [ deserialize ] with-byte-reader ] when ] } [ no-sql-type ] } case ; ! PQgetlength PQgetisnull diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 34150f4d85..6b614e1ddf 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -6,7 +6,9 @@ prettyprint tools.walker db.sqlite calendar 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 ; + : ( 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 ; -: ( id name age real ts date time blob -- person ) +: ( id name age real ts date time blob factor-blob -- 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 person1 set - "johnny" 10 3.14 f f f f 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 } person3 set ; + "billy" 10 3.14 f f f f f person1 set + "johnny" 10 3.14 f f f f f 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 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" } } person4 set ; : assigned-person-schema ( -- ) person "PERSON" @@ -118,10 +140,11 @@ 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 person1 set - 2 "johnny" 10 3.14 f f f f 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 } person3 set ; + 1 "billy" 10 3.14 f f f f f person1 set + 2 "johnny" 10 3.14 f f f f f 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 person3 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; @@ -168,7 +191,7 @@ TUPLE: annotation n paste-id summary author mode contents ; ! [ assigned-person-schema test-tuples ] test-sqlite [ native-person-schema test-tuples ] test-postgresql -[ assigned-person-schema test-tuples ] test-postgresql +! [ assigned-person-schema test-tuples ] test-postgresql TUPLE: serialize-me id data ; From f56b54077b8136e5886bab679b68663bcb958b7c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Mar 2008 00:18:57 -0500 Subject: [PATCH 05/15] more unit tests --- extra/db/sqlite/lib/lib.factor | 5 +++-- extra/db/tuples/tuples-tests.factor | 12 +++++++----- 2 files changed, 10 insertions(+), 7 deletions(-) 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 6b614e1ddf..2d873aaa22 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -144,7 +144,8 @@ SYMBOL: person4 } define-persistent 1 "billy" 10 3.14 f f f f f person1 set 2 "johnny" 10 3.14 f f f f f 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 person3 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 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" } } person4 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; @@ -187,11 +188,11 @@ TUPLE: annotation n paste-id summary author mode contents ; : 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-sqlite +[ assigned-person-schema test-tuples ] test-sqlite [ native-person-schema test-tuples ] test-postgresql -! [ assigned-person-schema test-tuples ] test-postgresql +[ assigned-person-schema test-tuples ] test-postgresql TUPLE: serialize-me id data ; @@ -209,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 ; From dcdee4ec6f2b86f444e0d536c9d2cf80cc785ff2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:30:14 -0500 Subject: [PATCH 06/15] Minor core features --- core/parser/parser.factor | 6 +++--- core/sequences/sequences.factor | 3 +++ core/splitting/splitting.factor | 6 +++--- 3 files changed, 9 insertions(+), 6 deletions(-) mode change 100644 => 100755 core/splitting/splitting.factor diff --git a/core/parser/parser.factor b/core/parser/parser.factor index cc84084258..1bdff49506 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 vocab -- 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 ; From 9565a04e74f6e5d3a2d6c40b3278a0002d711198 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:30:35 -0500 Subject: [PATCH 07/15] Tiny fry fix --- extra/fry/fry.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) 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 ; From 2c1e1d9a945615afa675006abe9142cdb18cc579 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:35:43 -0500 Subject: [PATCH 08/15] Rename smtp:send to smtp:send-email, simplify insomniac config --- extra/logging/insomniac/insomniac-docs.factor | 11 +------- extra/logging/insomniac/insomniac.factor | 27 ++++++------------- extra/smtp/server/server.factor | 4 +-- extra/smtp/smtp-tests.factor | 9 +++---- extra/smtp/smtp.factor | 23 +++++++--------- 5 files changed, 25 insertions(+), 49 deletions(-) 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 [ - - swap >>body - insomniac-recipients get >>to - insomniac-sender get >>from - swap email-subject >>subject - send - ] [ 2drop ] if - ] with-insomniac-smtp ; + dupd ?analyze-log dup [ + + 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/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 ascii [ 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 smtp-server set "Hi guys\nBye guys" >>body @@ -77,6 +76,6 @@ IN: smtp.tests "Ed " } >>to "Doug " >>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 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 - ascii [ + smtp-server get + dup log-smtp-connection + ascii [ 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 From 093ae20ed571b13d447e71fdd6badc9cbf011fd2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:35:59 -0500 Subject: [PATCH 09/15] Fix bug in regexp char class parser --- extra/regexp/regexp-tests.factor | 4 ++++ extra/regexp/regexp.factor | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) 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 matches? ] unit-test [ t ] [ "fooxbar" "foo\\Bxbar" f matches? ] unit-test [ f ] [ "foo" "foo\\Bbar" f matches? ] unit-test + +[ t ] [ "s@f" "[a-z.-]@[a-z]" f matches? ] unit-test +[ f ] [ "a" "[a-z.-]@[a-z]" f matches? ] unit-test +[ t ] [ ".o" "\\.[a-z]" f 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 "(" ")" 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 ) From 2b00bafdc16cec9b2fe225bfee401796ba3aac4e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:36:09 -0500 Subject: [PATCH 10/15] Update singleton for core changes --- extra/singleton/singleton.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/singleton/singleton.factor 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: From a463e6d9fbb86f0df9255bd0a5c8163e36b2bf62 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:36:19 -0500 Subject: [PATCH 11/15] Moved seq-intersect to core --- extra/units/units.factor | 3 --- 1 file changed, 3 deletions(-) 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 ; From dfacba5f3bd37e7888a20f3fb4532656b170ae98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:36:33 -0500 Subject: [PATCH 12/15] Clean up erg's change --- core/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 1bdff49506..81c9b68668 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -240,7 +240,7 @@ PREDICATE: unexpected unexpected-eof : CREATE ( -- word ) scan create-in ; -: create-class-in ( word vocab -- word ) +: create-class-in ( word -- word ) in get create dup save-class-location dup predicate-word dup set-word save-location ; From 60cf3950328ae5e76f2056c0e4f080ae12902913 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:37:45 -0500 Subject: [PATCH 13/15] Fix keyboard shortcut --- extra/ui/tools/tools.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 2b150db9b9ceb27b37853148f858539b1ca05d17 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:39:09 -0500 Subject: [PATCH 14/15] HTTP server work in progress --- extra/http/client/client.factor | 7 +- extra/http/http-tests.factor | 4 +- extra/http/http.factor | 18 +- .../http/server/actions/actions-tests.factor | 6 +- extra/http/server/actions/actions.factor | 66 ++-- extra/http/server/auth/auth.factor | 8 + .../http/server/auth/login/login-tests.factor | 6 + extra/http/server/auth/login/login.factor | 333 +++++++++++++++--- extra/http/server/auth/login/login.fhtml | 22 +- extra/http/server/auth/login/recover-1.fhtml | 38 ++ extra/http/server/auth/login/recover-2.fhtml | 9 + extra/http/server/auth/login/recover-3.fhtml | 43 +++ extra/http/server/auth/login/recover-4.fhtml | 10 + extra/http/server/auth/login/register.fhtml | 75 ++++ .../auth/providers/assoc/assoc-tests.factor | 31 +- .../server/auth/providers/assoc/assoc.factor | 22 +- .../server/auth/providers/db/db-tests.factor | 33 +- extra/http/server/auth/providers/db/db.factor | 56 ++- .../server/auth/providers/null/null.factor | 12 +- .../server/auth/providers/providers.factor | 54 ++- .../server/callbacks/callbacks-tests.factor | 64 ++++ extra/http/server/callbacks/callbacks.factor | 80 ++--- extra/http/server/cgi/cgi.factor | 14 +- .../server/components/components-tests.factor | 88 +++++ .../http/server/components/components.factor | 253 +++++++++---- .../server/components/farkup/farkup.factor | 13 + extra/http/server/components/test/form.fhtml | 1 + extra/http/server/crud/crud.factor | 72 +++- extra/http/server/db/db.factor | 10 +- extra/http/server/server-tests.factor | 34 +- extra/http/server/server.factor | 152 +++++--- .../server/sessions/sessions-tests.factor | 4 +- extra/http/server/sessions/sessions.factor | 79 +++-- extra/http/server/static/static.factor | 49 +-- .../templating/fhtml/fhtml-tests.factor | 8 +- .../http/server/templating/fhtml/fhtml.factor | 33 +- .../server/validators/validators-tests.factor | 22 +- .../http/server/validators/validators.factor | 39 +- extra/xmode/code2html/code2html.factor | 13 +- .../code2html/responder/responder.factor | 20 +- 40 files changed, 1419 insertions(+), 482 deletions(-) mode change 100644 => 100755 extra/http/server/actions/actions-tests.factor create mode 100755 extra/http/server/auth/auth.factor create mode 100755 extra/http/server/auth/login/login-tests.factor create mode 100755 extra/http/server/auth/login/recover-1.fhtml create mode 100755 extra/http/server/auth/login/recover-2.fhtml create mode 100755 extra/http/server/auth/login/recover-3.fhtml create mode 100755 extra/http/server/auth/login/recover-4.fhtml create mode 100755 extra/http/server/auth/login/register.fhtml create mode 100755 extra/http/server/callbacks/callbacks-tests.factor create mode 100755 extra/http/server/components/components-tests.factor create mode 100755 extra/http/server/components/farkup/farkup.factor create mode 100755 extra/http/server/components/test/form.fhtml mode change 100644 => 100755 extra/http/server/crud/crud.factor mode change 100644 => 100755 extra/http/server/validators/validators-tests.factor mode change 100644 => 100755 extra/http/server/validators/validators.factor 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>> ; : 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 ; [ - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>get + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display "quit" add-responder "extra/http/test" resource-path >>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 ; - [ "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 - [ +path+ get "xxx" get "X" concat append ] >>post + [ +path+ get "xxx" get "X" 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 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 ; + +\ 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" [ - "extra/http/server/auth/login/login.fhtml" - resource-path run-template-file - ] >>body ; +! ! ! Login -: - - [ login-page ] >>get +: + "login"
+ "resource:extra/http/server/auth/login/login.fhtml" >>edit-template + "username" + t >>required + add-field + "password" + t >>required + add-field ; - { - { "name" [ ] } - { "password" [ ] } - } >>post-params +: successful-login ( user -- response ) + logged-in-user sset + post-login-url sget f ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ 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 + +: ( -- form ) + "register" + "resource:extra/http/server/auth/login/register.fhtml" >>edit-template + "username" + t >>required + add-field + "realname" add-field + "password" + t >>required + add-field + "verify-password" + t >>required + add-field + "email" add-field + "captcha" add-field ; + +SYMBOL: password-mismatch? +SYMBOL: user-exists? + +: same-password-twice ( -- ) + "password" value "verify-password" value = [ + password-mismatch? on + validation-failed + ] unless ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + same-password-twice + + 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: + [ "[ " % 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 - ] [ - 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 ; -: +: send-password-email ( user -- ) + '[ , password-email smtp:send-email ] + "E-mail send thread" spawn drop ; + +: ( -- form ) + "register" + "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template + "username" + t >>required + add-field + "email" + t >>required + add-field + "captcha" add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ 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 + ] ; + +: + "new-password" + "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template + "username" + t >>required + add-field + "password" + t >>required + add-field + "verify-password" + t >>required + add-field + "ticket" + t >>required + add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ + { "username" [ v-required ] } + { "ticket" [ v-required ] } + ] >>get-params + + [ + [ + "username" [ get ] keep set + "ticket" [ get ] keep set + ] H{ } make-assoc values set + ] >>init + + [ + "text/html" + [ 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 +: ( -- action ) [ - f logged-in? sset - request get "login" - ] >>post ; + f logged-in-user sset + "login" f + ] >>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 - ] [ - 3drop <400> - ] if +! ! ! Authentication logic + +TUPLE: protected responder ; + +C: 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 + ] [ <400> ] if ] if ; -: ( responder provider -- auth ) - (login-auth) - - swap >>default - "login" add-responder - "logout" add-responder - ; +M: login call-responder ( path responder -- response ) + dup login set + delegate call-responder ; + +: ( responder -- auth ) + login + swap >>default + "login" add-responder + "logout" add-responder + no >>users ; + +! ! ! Configuration + +: allow-registration ( login -- login ) + "register" add-responder ; + +: allow-password-recovery ( login -- login ) + "recover-password" add-responder + "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 ; %>

Login required

@@ -7,19 +9,33 @@ User name: - +<% "username" component render-edit %> Password: - +<% "password" component render-edit %> - +

+<% +login-failed? get +[ "Invalid username or password" render-error ] when +%> +

+

+<% allow-registration? [ %> + Register +<% ] when %> +<% allow-password-recovery? [ %> + Recover Password +<% ] when %> +

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

Recover lost password: step 1 of 4

+ +

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.

+ +
+ + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-edit %>
E-mail:<% "email" component render-edit %>
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
+ + + +
+ + + 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 ; %> + + +

Recover lost password: step 2 of 4

+ +

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.

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

Recover lost password: step 3 of 4

+ +

Choose a new password for your account.

+ +
+ + +<% "username" component render-edit %> +<% "ticket" component render-edit %> + + + + + + + + + + + + + + + + +
Password:<% "password" component render-edit %>
Verify password:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
+ +

+ +<% password-mismatch? get [ +"passwords do not match" render-error +] when %> + +

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

Recover lost password: step 4 of 4

+ +

Your password has been reset. You may now log in.

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

New user registration

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-edit %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Password:<% "password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
+ +

+ +<% { + { [ password-mismatch? get ] [ "passwords do not match" render-error ] } + { [ user-exists? get ] [ "username taken" render-error ] } + { [ t ] [ ] } +} cond %> + +

+ +
+ + + 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 ; - "provider" set + "provider" set -"slava" "provider" get new-user +[ t ] [ + + "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 ] [ + + "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 ; -: ( -- provider ) - H{ } clone assoc-auth-provider construct-boa ; +: ( -- 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 ] [ + + "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 ] [ + + "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 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 ) - 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 [ - - 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 - [ - - 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 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 ] [ + [ + "GET" >>method request set + [ + exit-continuation set + "xxx" + [ [ "hello" print 123 ] show-final ] >>get + + call-responder + ] callcc1 + ] with-scope +] unit-test + +[ + [ + [ + "hello" print + "text/html" swap '[ , write ] >>body + ] show-page + "byebye" print + [ 123 ] show-final + ] >>get + "r" set + + [ 123 ] [ + [ + exit-continuation set + "GET" >>method request set + "" "r" get call-responder + ] callcc1 + + body>> first + + + "GET" >>method + swap cont-id associate >>query + "/" >>path + request set + + [ + exit-continuation set + "/" + "r" get call-responder + ] callcc1 + + ! get-post-get + + "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 ; : ( 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 ) - - responder get callbacks>> generate-key - [ responder get callbacks>> set-at ] keep ; + 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 exit-with ; + 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 over 1array >>command swap cgi-variables >>environment ; - + : serve-cgi ( name -- response ) 200 >>code "CGI output follows" >>message - swap [ - stdio get swap [ - post? [ - request get post-data>> write flush - ] when + swap '[ + , stdio get swap [ + 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" validate ] unit-test + +[ 123 ] [ + "" + "n" + 123 >>default + validate +] unit-test + +[ f ] [ validation-failed? get ] unit-test + +[ t ] [ "3x" "n" validate validation-error? ] unit-test + +[ t ] [ validation-failed? get ] unit-test + +[ "" ] [ "" "email" validate ] unit-test + +[ "slava@jedit.org" ] [ "slava@jedit.org" "email" validate ] unit-test + +[ "slava@jedit.org" ] [ + "slava@jedit.org" + "email" + t >>required + validate +] unit-test + +[ t ] [ + "a" + "email" + t >>required + validate validation-error? +] unit-test + +[ t ] [ "a" "email" validate validation-error? ] unit-test + +TUPLE: test-tuple text number more-text ; + +: test-tuple construct-empty ; + +: ( -- form ) + "test"
+ "resource:extra/http/server/components/test/form.fhtml" >>view-template + "resource:extra/http/server/components/test/form.fhtml" >>edit-template + "text" + t >>required + add-field + "number" + 123 >>default + t >>required + 0 >>min-value + 10 >>max-value + add-field + "more-text" + "hi" >>default + add-field ; + +[ ] [ values set view-form ] unit-test + +[ ] [ values set edit-form ] unit-test + +[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [ + from-tuple + set-defaults + values-tuple +] unit-test + +[ + H{ + { "text" "fdafsa" } + { "number" "xxx" } + { "more-text" "" } + } params set + + H{ } clone values set + + [ t ] [ (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 -- ) write ; : 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 ; -: ( id string -- component ) - >r \ component construct-boa r> construct-delegate ; inline +: ( id class -- component ) + \ component construct-empty + swap construct-delegate + swap >>id ; inline -TUPLE: string min max ; +! Forms +TUPLE: form view-template edit-template components ; + +: ( id -- form ) + form + 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 values set ; + +: values-tuple values get mirror-object ; + +! ! ! +! Canned components: for simple applications and prototyping +! ! ! + +: render-input ( value component type -- ) + > [ =id ] [ =name ] bi + =value + input/> ; + +! Hidden fields +TUPLE: 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 ; : ( id -- component ) string ; 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 - > 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 ; + +: ( id -- component ) + username construct-delegate + 2 >>min-length + 20 >>max-length ; + +M: username validate* + delegate validate* v-one-word ; + +! E-mail fields +TUPLE: email ; + +: ( id -- component ) + email construct-delegate + 5 >>min-length + 60 >>max-length ; + +M: email validate* + delegate validate* dup empty? [ v-email ] unless ; + +! Password fields +TUPLE: password ; + +: ( id -- component ) + 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 ; + +: ( id -- component ) number ; + +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 ; : ( id -- component ) text construct-delegate ; : render-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 ; -: ( id -- component ) farkup construct-delegate ; +: ( id -- component ) + captcha construct-delegate ; -M: farkup render-view* - drop string-lines "\n" join convert-farkup write ; - -TUPLE: number min max ; - -: ( id -- component ) number ; - -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 ; - -: ( 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 ; + +: ( id -- component ) + 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 ; - -: ( class -- action ) +:: ( form ctor -- 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" + [ form view-form ] >>body + ] >>display ; + +: ( id next -- response ) + swap number>string "id" associate ; + +:: ( form ctor next -- action ) + + [ f ctor call from-tuple form set-defaults ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple insert-tuple + + "id" value next + ] >>submit ; + +:: ( form ctor next -- action ) + + { { "id" [ v-number ] } } >>get-params + [ "id" get ctor call select-tuple from-tuple ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple update-tuple + + "id" value next + ] >>submit ; + +:: ( ctor next -- action ) + + { { "id" [ v-number ] } } >>post-params + + [ + "id" get ctor call delete-tuple + + next f + ] >>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 : 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 +[ + + "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 M: mock-responder call-responder - 2nip + nip path>> on "text/plain" ; : check-dispatch ( tag path -- ? ) over off - swap default-host get call-responder + main-responder get call-responder write-response get ; [ @@ -24,14 +41,14 @@ M: mock-responder call-responder "123" "123" add-responder "default" >>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 ] [ "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 [ "default" >>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-type -- 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 -- ) -

swap number>string write bl write

+

[ number>string write bl ] [ write ] bi*

; : ( code message -- response ) - - 2over [ trivial-response-body ] 2curry >>body - "text/html" set-content-type - swap >>message - swap >>code ; + 2dup '[ , , trivial-response-body ] + "text/html" + swap >>body + swap >>message + swap >>code ; : <400> ( -- response ) 400 "Bad request" ; @@ -37,41 +42,58 @@ M: trivial-responder call-responder nip response>> call ; SYMBOL: 404-responder -[ drop <404> ] 404-responder set-global +[ <404> ] 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 ; -: ( request to code message -- response ) - - -rot modify-for-redirect - "location" set-header ; +: ( to query code message -- response ) + -rot derive-url "location" set-header ; \ DEBUG add-input-logging -: ( request to -- response ) +: ( to query -- response ) 301 "Moved Permanently" ; -: ( request to -- response ) +: ( to query -- response ) 307 "Temporary Redirect" ; -: ( content-type -- response ) - - 200 >>code - swap set-content-type ; - TUPLE: dispatcher default responders ; : ( -- dispatcher ) - 404-responder H{ } clone dispatcher construct-boa ; + 404-responder get H{ } clone dispatcher construct-boa ; : set-main ( dispatcher name -- dispatcher ) - [ ] curry - >>default ; + '[ , f ] + >>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 ; +: redirect-with-/ ( -- response ) + request get path>> "/" append f ; -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 : ( class -- 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" - 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 -M: foo init-session drop 0 "x" sset ; +M: foo init-session* drop 0 "x" sset ; -"1234" f [ +f [ [ ] [ 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 ; -: ( id manager -- session ) - H{ } clone \ session construct-boa ; +: ( manager -- session ) + f H{ } clone \ 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 - [ dup touch-session ] keep - [ swap \ session [ responder>> init-session ] with-variable ] 2keep - >r over r> sessions>> set-at ; + [ 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 ; + +M: null-sessions call-responder ( path responder -- response ) + dup call-responder/session ; + TUPLE: 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 + nip + f swap new-session sess-id associate ] 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 ; : ( responder -- responder' ) cookie-sessions ; -: 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* ; : ( id -- cookie ) sess-id ; -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 ; : ( root -- responder ) [ - over file-length "content-length" set-header - over file-http-date "last-modified" set-header - swap [ binary stdio get stream-copy ] curry >>body + swap + [ file-length "content-length" set-header ] + [ file-http-date "last-modified" set-header ] + [ '[ , binary stdio get stream-copy ] >>body ] + tri ] ; : 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 [ -

dup file-name write

-
    - directory sort-keys - [
  • file.
    • ] assoc-each -
+ [

file-name write

] + [ +
    + directory sort-keys + [
  • file.
    • ] assoc-each +
+ ] bi ] simple-html-document ; : list-directory ( directory -- response ) "text/html" - 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 -- ) 
 error.
; -: 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" + swap '[ , run-template ] >>body ; ! file responder integration -: serve-fhtml ( filename -- response ) - "text/html" - 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/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 ; : htmlize-file ( path -- ) - dup utf8 over ".html" append utf8 - [ 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 : ( root -- responder ) [ drop - "text/html" - over file-http-date "last-modified" set-header - swap [ - dup file-name swap htmlize-stream - ] curry >>body + "text/html" swap + [ file-http-date "last-modified" set-header ] + [ + '[ + , + dup file-name swap utf8 + + [ htmlize-stream ] with-html-stream + ] >>body + ] bi ] ; From ae3963a07217ac7c2ccba518d4c213e93294258b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:39:50 -0500 Subject: [PATCH 15/15] Fix builder for word renaming --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/builder/builder.factor 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!