Merge branch 'master' into experimental2

core/parser/parser.factor

@@ -240,13 +240,13 @@ PREDICATE: unexpected unexpected-eof
 
 : CREATE ( -- word ) scan create-in ;
 
-: create-class ( word vocab -- word )
+: create-class-in ( word -- word )
-    create
+    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 [

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 ;
 

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 ;

extra/builder/builder.factor

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

extra/db/postgresql/ffi/ffi.factor

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

extra/db/postgresql/lib/lib.factor

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

extra/db/postgresql/postgresql.factor

@@ -55,7 +55,7 @@ M: postgresql-result-set #columns ( result-set -- n )
     result-set-handle PQnfields ;
 
 M: postgresql-result-set row-column ( result-set column -- obj )
-    >r dup result-set-handle swap result-set-n r> PQgetvalue ;
+    >r dup result-set-handle swap result-set-n r> pq-get-string ;
 
 M: postgresql-result-set row-column-typed ( result-set column -- obj )
     dup pick result-set-out-params nth sql-spec-type
@@ -238,10 +238,13 @@ M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
 
         " from " 0% 0%
         [ sql-spec-slot-name swap get-slot-named ] with subset
+        dup empty? [
+            drop
+        ] [
             " where " 0%
-        [ ", " 0% ]
+            [ " and " 0% ]
             [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
-        ";" 0%
+        ] 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 )

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 ]

extra/db/tuples/tuples-tests.factor

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

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 ;

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
+splitting calendar continuations accessors vectors
-io.encodings.binary ;
+io.encodings.latin1 io.encodings.binary fry ;
 IN: http.client
 
 DEFER: http-request
@@ -46,8 +46,7 @@ DEFER: http-request
     dup host>> swap port>> <inet> ;
 
 : close-on-error ( stream quot -- )
-    [ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ;
+    '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
-    inline
 
 PRIVATE>
 

extra/http/http-tests.factor

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

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
+USING: fry hashtables io io.streams.string kernel math
-math.parser assocs sequences strings splitting ascii
+namespaces math.parser assocs sequences strings splitting ascii
-io.encodings.utf8 io.encodings.string namespaces
+io.encodings.utf8 io.encodings.string namespaces unicode.case
-unicode.case combinators vectors sorting new-slots accessors
+combinators vectors sorting new-slots accessors calendar
-calendar calendar.format quotations arrays ;
+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?
+    dup "\r\n" seq-intersect empty?
-    [ "Header injection attack" throw ] when ;
+    [ "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 

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

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

extra/http/server/actions/actions.factor

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

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

extra/http/server/auth/login/login-tests.factor

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

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.auth.providers http.server.auth.providers.null
-http.server.sessions http.server.templating.fhtml http sequences
+http.server.actions http.server.components http.server.sessions
-io.files namespaces ;
+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 )
+! ! ! Login
-    "text/html" <content> [
-        "extra/http/server/auth/login/login.fhtml"
-        resource-path run-template-file
-    ] >>body ;
 
-: <login-action>
+: <login-form>
+    "login" <form>
+        "resource:extra/http/server/auth/login/login.fhtml" >>edit-template
+        "username" <username>
+            t >>required
+            add-field
+        "password" <password>
+            t >>required
+            add-field ;
+
+: successful-login ( user -- response )
+    logged-in-user sset
+    post-login-url sget f <permanent-redirect> ;
+
+:: <login-action> ( -- action )
+    [let | form [ <login-form> ] |
         <action>
-        [ login-page ] >>get
+            [ blank-values ] >>init
 
-        {
-            { "name" [ ] }
-            { "password" [ ] }
-        } >>post-params
             [
-            "password" get
+                "text/html" <content>
-            "name" get
+                [ form edit-form ] >>body
-            provider sget check-login [
+            ] >>display
-                t logged-in? sset
-                post-login-url sget <permanent-redirect>
-            ] [
-                login-page
-            ] if
-        ] >>post ;
 
-: <logout-action>
+            [
+                blank-values
+
+                form validate-form
+
+                "password" value "username" value
+                login get users>> check-login [
+                    successful-login
+                ] [
+                    login-failed? on
+                    validation-failed
+                ] if*
+            ] >>submit
+    ] ;
+
+! ! ! New user registration
+
+: <register-form> ( -- form )
+    "register" <form>
+        "resource:extra/http/server/auth/login/register.fhtml" >>edit-template
+        "username" <username>
+            t >>required
+            add-field
+        "realname" <string> add-field
+        "password" <password>
+            t >>required
+            add-field
+        "verify-password" <password>
+            t >>required
+            add-field
+        "email" <email> add-field
+        "captcha" <captcha> add-field ;
+
+SYMBOL: password-mismatch?
+SYMBOL: user-exists?
+
+: same-password-twice ( -- )
+    "password" value "verify-password" value = [ 
+        password-mismatch? on
+        validation-failed
+    ] unless ;
+
+:: <register-action> ( -- action )
+    [let | form [ <register-form> ] |
+        <action>
+            [ blank-values ] >>init
+
+            [
+                "text/html" <content>
+                [ form edit-form ] >>body
+            ] >>display
+
+            [
+                blank-values
+
+                form validate-form
+
+                same-password-twice
+
+                <user> values get [
+                    "username" get >>username
+                    "realname" get >>realname
+                    "password" get >>password
+                    "email" get >>email
+                ] bind
+
+                login get users>> new-user [
+                    user-exists? on
+                    validation-failed
+                ] unless*
+
+                successful-login
+            ] >>submit
+    ] ;
+
+! ! ! Password recovery
+
+SYMBOL: lost-password-from
+
+: current-host ( -- string )
+    request get host>> host-name or ;
+
+: new-password-url ( user -- url )
+    "new-password"
+    swap [
+        [ username>> "username" set ]
+        [ ticket>> "ticket" set ]
+        bi
+    ] H{ } make-assoc
+    derive-url ;
+
+: password-email ( user -- email )
+    smtp:<email>
+        [ "[ " % current-host % " ] password recovery" % ] "" make >>subject
+        lost-password-from get >>from
+        over email>> 1array >>to
+        [
+            "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 ;
+
+: <recover-form-1> ( -- form )
+    "register" <form>
+        "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template
+        "username" <username>
+            t >>required
+            add-field
+        "email" <email>
+            t >>required
+            add-field
+        "captcha" <captcha> add-field ;
+
+:: <recover-action-1> ( -- action )
+    [let | form [ <recover-form-1> ] |
+        <action>
+            [ blank-values ] >>init
+
+            [
+                "text/html" <content>
+                [ form edit-form ] >>body
+            ] >>display
+
+            [
+                blank-values
+
+                form validate-form
+
+                "email" value "username" value
+                login get users>> issue-ticket [
+                    send-password-email
+                ] when*
+
+                "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template
+            ] >>submit
+    ] ;
+
+: <recover-form-3>
+    "new-password" <form>
+        "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template
+        "username" <username> <hidden>
+            t >>required
+            add-field
+        "password" <password>
+            t >>required
+            add-field
+        "verify-password" <password>
+            t >>required
+            add-field
+        "ticket" <string> <hidden>
+            t >>required
+            add-field ;
+
+:: <recover-action-3> ( -- action )
+    [let | form [ <recover-form-3> ] |
         <action>
             [
-            f logged-in? sset
+                { "username" [ v-required ] }
-            request get "login" <permanent-redirect>
+                { "ticket" [ v-required ] }
-        ] >>post ;
+            ] >>get-params
 
-M: login-auth call-responder ( request path responder -- response )
+            [
-    logged-in? sget
+                [
-    [ responder>> call-responder ] [
+                    "username" [ get ] keep set
-        pick method>> "GET" = [
+                    "ticket" [ get ] keep set
-            nip
+                ] H{ } make-assoc values set
-            provider>> provider sset
+            ] >>init
-            dup request-url post-login-url sset
+
-            "login" f session-link <permanent-redirect>
+            [
+                "text/html" <content>
+                [ <recover-form-3> edit-form ] >>body
+            ] >>display
+
+            [
+                blank-values
+
+                form validate-form
+
+                same-password-twice
+
+                "ticket" value
+                "username" value
+                login get users>> claim-ticket [
+                    "password" value >>password
+                    login get users>> update-user
+
+                    "resource:extra/http/server/auth/login/recover-4.fhtml"
+                    serve-template
                 ] [
-            3drop <400>
+                    <400>
-        ] if
+                ] if*
+            ] >>submit
+    ] ;
+
+! ! ! Logout
+: <logout-action> ( -- action )
+    <action>
+        [
+            f logged-in-user sset
+            "login" f <permanent-redirect>
+        ] >>submit ;
+
+! ! ! Authentication logic
+
+TUPLE: protected responder ;
+
+C: <protected> protected
+
+M: protected call-responder ( path responder -- response )
+    logged-in-user sget [ responder>> call-responder ] [
+        2drop
+        request get method>> { "GET" "HEAD" } member? [
+            request get request-url post-login-url sset
+            "login" f <permanent-redirect>
+        ] [ <400> ] if
     ] if ;
 
-: <login-auth> ( responder provider -- auth )
+M: login call-responder ( path responder -- response )
-        (login-auth)
+    dup login set
-        <dispatcher>
+    delegate call-responder ;
-            swap >>default
+
+: <login> ( responder -- auth )
+    login <webapp>
+        swap <protected> >>default
         <login-action> "login" add-responder
         <logout-action> "logout" add-responder
-    <cookie-sessions> ;
+        no >>users ;
+
+! ! ! Configuration
+
+: allow-registration ( login -- login )
+    <register-action> "register" add-responder ;
+
+: allow-password-recovery ( login -- login )
+    <recover-action-1> "recover-password" add-responder
+    <recover-action-3> "new-password" add-responder ;
+
+: allow-registration? ( -- ? )
+    login get responders>> "register" swap key? ;
+
+: allow-password-recovery? ( -- ? )
+    login get responders>> "recover-password" swap key? ;

extra/http/server/auth/login/login.fhtml

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

extra/http/server/auth/login/recover-1.fhtml

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

extra/http/server/auth/login/recover-2.fhtml

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

extra/http/server/auth/login/recover-3.fhtml

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

extra/http/server/auth/login/recover-4.fhtml

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

extra/http/server/auth/login/register.fhtml

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

extra/http/server/auth/providers/assoc/assoc-tests.factor

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

extra/http/server/auth/providers/assoc/assoc.factor

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

extra/http/server/auth/providers/db/db-tests.factor

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

extra/http/server/auth/providers/db/db.factor

@@ -1,53 +1,45 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: db db.tuples db.types new-slots accessors
-http.server.auth.providers kernel ;
+http.server.auth.providers kernel continuations ;
 IN: http.server.auth.providers.db
 
-TUPLE: user name password ;
-
-: <user> user construct-empty ;
-
 user "USERS"
 {
-    { "name" "NAME" { VARCHAR 256 } +assigned-id+ }
+    { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
+    { "realname" "REALNAME" { VARCHAR 256 } }
     { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
+    { "email" "EMAIL" { VARCHAR 256 } }
+    { "ticket" "TICKET" { VARCHAR 256 } }
+    { "profile" "PROFILE" FACTOR-BLOB }
 } define-persistent
 
 : init-users-table ( -- )
+    [ user drop-table ] ignore-errors
     user create-table ;
 
-TUPLE: db-auth-provider ;
+TUPLE: from-db ;
 
-: db-auth-provider T{ db-auth-provider } ;
+: from-db T{ from-db } ;
 
-M: db-auth-provider check-login
+: find-user ( username -- user )
-    drop
     <user>
-    swap >>name
+        swap >>username
-    swap >>password
+    select-tuple ;
-    select-tuple >boolean ;
 
-M: db-auth-provider new-user
+M: from-db get-user
+    drop
+    find-user ;
+
+M: from-db new-user
     drop
     [
-        <user>
+        dup username>> find-user [
-        swap >>name
+            drop f
-
+        ] [
-        dup select-tuple [ name>> user-exists ] when
+            dup insert-tuple
-
+        ] if
-        "unassigned" >>password
-
-        insert-tuple
     ] with-transaction ;
 
-M: db-auth-provider set-password
+M: from-db update-user
-    drop
+    drop update-tuple ;
-    [
-        <user>
-        swap >>name
-
-        dup select-tuple [ ] [ no-such-user ] ?if
-
-        swap >>password update-tuple
-    ] with-transaction ;

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 ;

extra/http/server/auth/providers/providers.factor

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

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

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

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
+    [ alarm>> cancel-alarm ]
-    dup responder>> callbacks>> delete-at ;
+    [ dup responder>> callbacks>> delete-at ]
+    bi ;
 
 : touch-callback ( callback -- )
     dup expires>> [
         dup alarm>> [ cancel-alarm ] when*
-        dup [ timeout-callback ] curry timeout later >>alarm
+        dup '[ , timeout-callback ] timeout later >>alarm
     ] when drop ;
 
 : <callback> ( cont quot expires? -- callback )
-    [ f responder get callback construct-boa ] keep
+    f callback-responder get callback construct-boa
-    [ dup touch-callback ] when ;
+    dup touch-callback ;
 
-: invoke-callback ( request exit-cont callback -- response )
+: invoke-callback ( callback -- response )
-    [ quot>> 3array ] keep cont>> continue-with ;
+    [ touch-callback ]
+    [ quot>> request get exit-continuation get 3array ]
+    [ cont>> continue-with ]
+    tri ;
 
 : register-callback ( cont quot expires? -- id )
-    <callback>
+    <callback> callback-responder get callbacks>> set-at-unique ;
-    responder get callbacks>> generate-key
-    [ responder get callbacks>> set-at ] keep ;
 
-SYMBOL: exit-continuation
+: forward-to-url ( url query -- * )
-
-: exit-with exit-continuation get continue-with ;
-
-: forward-to-url ( url -- * )
     #! When executed inside a 'show' call, this will force a
     #! HTTP 302 to occur to instruct the browser to forward to
     #! the request URL.
-    request get swap <temporary-redirect> exit-with ;
+    <temporary-redirect> exit-with ;
 
 : cont-id "factorcontid" ;
 
-: id>url ( id -- url )
-    request get
-    swap cont-id associate >>query
-    request-url ;
-
 : forward-to-id ( id -- * )
     #! When executed inside a 'show' call, this will force a
     #! HTTP 302 to occur to instruct the browser to forward to
     #! the request URL.
-    id>url forward-to-url ;
+    f swap cont-id associate forward-to-url ;
 
 : restore-request ( pair -- )
-    first3 >r exit-continuation set request set r> call ;
+    first3 exit-continuation set request set call ;
-
-: resume-page ( request page responder callback -- * )
-    dup touch-callback
-    >r 2drop exit-continuation get
-    r> invoke-callback ;
 
 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 redirect-to-here store-current-show r>
-    r> call exit-with ; inline
+    call exit-with ; inline
 
-M: callback-responder call-responder
+: resuming-callback ( responder request -- id )
-    [
+    cont-id query-param swap callbacks>> at ;
-        [
+
-            exit-continuation set
+M: callback-responder call-responder ( path responder -- response )
-            dup responder set
+    [ callback-responder set ]
-            pick request set
+    [ request get resuming-callback ] bi
-            pick cont-id query-param over callbacks>> at [
+
-                resume-page
+    [ invoke-callback ]
-            ] [
+    [ callback-responder get responder>> call-responder ] ?if ;
-                responder>> call-responder
-                "Continuation responder pages must use show-final" throw
-            ] if*
-        ] with-scope
-    ] callcc1 >r 3drop r> ;
 
 : show-page ( quot -- )
     >r redirect-to-here store-current-show r>
     [
-        [ ] register-callback
+        [ ] t register-callback swap call exit-with
-        with-scope
-        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 ;

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" = ;
@@ -50,14 +50,12 @@ IN: http.server.cgi
     <raw-response>
     200 >>code
     "CGI output follows" >>message
-    swap [
+    swap '[
-        stdio get swap <cgi-process> <process-stream> [
+        , stdio get swap <cgi-process> <process-stream> [
-            post? [
+            post? [ request get post-data>> write flush ] when
-                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"

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

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

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

extra/http/server/components/farkup/farkup.factor

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

extra/http/server/components/test/form.fhtml

@@ -0,0 +1 @@
+

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
+USING: kernel namespaces db.tuples math.parser http.server
-http.server.actions accessors ;
+http.server.actions http.server.components
+http.server.validators accessors fry locals hashtables ;
 
-: by-id ( class -- tuple )
+:: <view-action> ( form ctor -- action )
-    construct-empty "id" get >>id ;
-
-: <delete-action> ( class -- action )
     <action>
-        { { "id" [ string>number ] } } >>post-params
+        { { "id" [ v-number ] } } >>get-params
-        swap [ by-id delete-tuple f ] curry >>post ;
+
+        [ "id" get ctor call select-tuple from-tuple ] >>init
+
+        [
+            "text/html" <content>
+            [ form view-form ] >>body
+        ] >>display ;
+
+: <id-redirect> ( id next -- response )
+    swap number>string "id" associate <permanent-redirect> ;
+
+:: <create-action> ( form ctor next -- action )
+    <action>
+        [ f ctor call from-tuple form set-defaults ] >>init
+
+        [
+            "text/html" <content>
+            [ form edit-form ] >>body
+        ] >>display
+
+        [
+            f ctor call from-tuple
+
+            form validate-form
+
+            values-tuple insert-tuple
+
+            "id" value next <id-redirect>
+        ] >>submit ;
+
+:: <edit-action> ( form ctor next -- action )
+    <action>
+        { { "id" [ v-number ] } } >>get-params
+        [ "id" get ctor call select-tuple from-tuple ] >>init
+
+        [
+            "text/html" <content>
+            [ form edit-form ] >>body
+        ] >>display
+
+        [
+            f ctor call from-tuple
+
+            form validate-form
+
+            values-tuple update-tuple
+
+            "id" value next <id-redirect>
+        ] >>submit ;
+
+:: <delete-action> ( ctor next -- action )
+    <action>
+        { { "id" [ v-number ] } } >>post-params
+
+        [
+            "id" get ctor call delete-tuple
+
+            next f <permanent-redirect>
+        ] >>submit ;

extra/http/server/db/db.factor

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

extra/http/server/server-tests.factor

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

extra/http/server/server.factor

@@ -4,10 +4,15 @@ USING: assocs kernel namespaces io io.timeouts strings splitting
 threads http sequences prettyprint io.server logging calendar
 new-slots html.elements accessors math.parser combinators.lib
 vocabs.loader debugger html continuations random combinators
-destructors io.encodings.latin1 ;
+destructors io.encodings.latin1 fry combinators.cleave ;
 IN: http.server
 
-GENERIC: call-responder ( request path responder -- response )
+GENERIC: call-responder ( path responder -- response )
+
+: <content> ( content-type -- response )
+    <response>
+        200 >>code
+        swap set-content-type ;
 
 TUPLE: trivial-responder response ;
 
@@ -18,14 +23,14 @@ M: trivial-responder call-responder nip response>> call ;
 : trivial-response-body ( code message -- )
     <html>
         <body>
-            <h1> swap number>string write bl write </h1>
+            <h1> [ number>string write bl ] [ write ] bi* </h1>
         </body>
     </html> ;
 
 : <trivial-response> ( code message -- response )
-    <response>
+    2dup '[ , , trivial-response-body ]
-    2over [ trivial-response-body ] 2curry >>body
+    "text/html" <content>
-    "text/html" set-content-type
+        swap >>body
         swap >>message
         swap >>code ;
 
@@ -37,41 +42,58 @@ M: trivial-responder call-responder nip response>> call ;
 
 SYMBOL: 404-responder
 
-[ drop <404> ] <trivial-responder> 404-responder set-global
+[ <404> ] <trivial-responder> 404-responder set-global
 
-: modify-for-redirect ( request to -- url )
+: url-redirect ( to query -- url )
+    #! Different host.
+    dup assoc-empty? [
+        drop
+    ] [
+        assoc>query "?" swap 3append
+    ] if ;
+
+: absolute-redirect ( to query -- url )
+    #! Same host.
+    request get clone
+        swap [ >>query ] when*
+        swap >>path
+    request-url ;
+
+: replace-last-component ( path with -- path' )
+    >r "/" last-split1 drop "/" r> 3append ;
+
+: relative-redirect ( to query -- url )
+    request get clone
+    swap [ >>query ] when*
+    swap [ '[ , replace-last-component ] change-path ] when*
+    request-url ;
+
+: derive-url ( to query -- url )
     {
-        { [ dup "http://" head? ] [ nip ] }
+        { [ over "http://" head? ] [ url-redirect ] }
-        { [ dup "/" head? ] [ >>path request-url ] }
+        { [ over "/" head? ] [ absolute-redirect ] }
-        { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] }
+        { [ t ] [ relative-redirect ] }
     } cond ;
 
-: <redirect> ( request to code message -- response )
+: <redirect> ( to query code message -- response )
-    <trivial-response>
+    <trivial-response> -rot derive-url "location" set-header ;
-    -rot modify-for-redirect
-    "location" set-header ;
 
 \ <redirect> DEBUG add-input-logging
 
-: <permanent-redirect> ( request to -- response )
+: <permanent-redirect> ( to query -- response )
     301 "Moved Permanently" <redirect> ;
 
-: <temporary-redirect> ( request to -- response )
+: <temporary-redirect> ( to query -- response )
     307 "Temporary Redirect" <redirect> ;
 
-: <content> ( content-type -- response )
-    <response>
-    200 >>code
-    swap set-content-type ;
-
 TUPLE: dispatcher default responders ;
 
 : <dispatcher> ( -- dispatcher )
-    404-responder H{ } clone dispatcher construct-boa ;
+    404-responder get H{ } clone dispatcher construct-boa ;
 
 : set-main ( dispatcher name -- dispatcher )
-    [ <permanent-redirect> ] curry
+    '[ , f <permanent-redirect> ] <trivial-responder>
-    <trivial-responder> >>default ;
+    >>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 )
+: redirect-with-/ ( -- response )
-    dup path>> "/" append <permanent-redirect> ;
+    request get path>> "/" append f <permanent-redirect> ;
 
-M: dispatcher call-responder
+M: dispatcher call-responder ( path dispatcher -- response )
     over [
-        3dup find-responder call-responder [
+        2dup find-responder call-responder [
-            >r 3drop r>
+            2nip
         ] [
             default>> [
                 call-responder
             ] [
-                3drop f
+                drop f
             ] if*
         ] if*
     ] [
@@ -107,21 +129,18 @@ M: dispatcher call-responder
 : <webapp> ( class -- dispatcher )
     <dispatcher> swap construct-delegate ; inline
 
-SYMBOL: virtual-hosts
+SYMBOL: main-responder
-SYMBOL: default-host
 
-virtual-hosts global [ drop H{ } clone ] cache drop
+main-responder global
-default-host global [ drop 404-responder get-global ] cache drop
+[ drop 404-responder get-global ] cache
-
+drop
-: find-virtual-host ( host -- responder )
-    virtual-hosts get at [ default-host get ] unless* ;
 
 SYMBOL: development-mode
 
 : <500> ( error -- response )
     500 "Internal server error" <trivial-response>
-    swap [
+    swap '[
-        "Internal server error" [
+        , "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-request do-response
+        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?
+    >r random-256 >hex r>
-    [ drop generate-key ] [ nip ] if ;
+    2dup key? [ nip generate-key ] [ drop ] if ;
+
+: set-at-unique ( value assoc -- key )
+    dup generate-key [ swap set-at ] keep ;

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

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

extra/http/server/sessions/sessions.factor

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

extra/http/server/static/static.factor

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

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
+        ".fhtml" append [ run-template ] with-string-writer
-        [ run-template-file ] 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

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

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

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 ;

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

extra/logging/insomniac/insomniac.factor

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

extra/regexp/regexp-tests.factor

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

extra/regexp/regexp.factor

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

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:

extra/smtp/server/server.factor

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

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
+        "localhost" 4321 <inet> smtp-server set
-        4321 smtp-port set
 
         <email>
             "Hi guys\nBye guys" >>body
@@ -77,6 +76,6 @@ IN: smtp.tests
                 "Ed <dharmatech@factorcode.org>"
             } >>to
             "Doug <erg@factorcode.org>" >>from
-        send
+        send-email
     ] with-scope
 ] unit-test

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-server     "localhost" 25 <inet> smtp-server set-global
-SYMBOL: smtp-port       25 smtp-port set-global
 SYMBOL: read-timeout    1 minutes read-timeout set-global
 SYMBOL: esmtp           t esmtp set-global
 
-: log-smtp-connection ( host port -- ) 2drop ;
+LOG: log-smtp-connection NOTICE ( addrspec -- )
-
-\ log-smtp-connection NOTICE add-input-logging
 
 : with-smtp-connection ( quot -- )
-    smtp-host get smtp-port get
+    smtp-server get
-    2dup log-smtp-connection
+    dup log-smtp-connection
-    <inet> ascii <client> [
+    ascii <client> [
         smtp-domain [ host-name or ] change
         read-timeout get stdio get set-timeout
         call
@@ -33,8 +30,8 @@ SYMBOL: esmtp           t esmtp set-global
 
 : validate-address ( string -- string' )
     #! Make sure we send funky stuff to the server by accident.
-    dup [ "\r\n>" member? ] contains?
+    dup "\r\n>" seq-intersect empty?
-    [ "Bad e-mail address: " swap append throw ] when ;
+    [ "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?
+    dup "\r\n" seq-intersect empty?
-    [ "Invalid header string: " swap append throw ] when ;
+    [ "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

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

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

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 ;
 

extra/xmode/code2html/code2html.factor

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

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
+USING: io.files io.encodings.utf8 namespaces http.server
-xmode.code2html kernel html sequences accessors ;
+http.server.static http xmode.code2html kernel html sequences
+accessors fry combinators.cleave ;
 IN: xmode.code2html.responder
 
 : <sources> ( root -- responder )
     [
         drop
-        "text/html" <content>
+        "text/html" <content> swap
-        over file-http-date "last-modified" set-header
+        [ file-http-date "last-modified" set-header ]
-        swap [
+        [
-            dup file-name swap <file-reader> htmlize-stream
+            '[
-        ] curry >>body
+                ,
+                dup file-name swap utf8
+                <file-reader>
+                [ htmlize-stream ] with-html-stream
+            ] >>body
+        ] bi
     ] <file-responder> ;