From 718adfd81e79f8a3e622a572384b71478837ac42 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 9 Mar 2008 06:54:53 -0500 Subject: [PATCH 01/14] Comment out units unit test at Dan's request --- extra/units/units-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/units/units-tests.factor diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor old mode 100644 new mode 100755 index 81f3163a77..9f0e704157 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -20,4 +20,4 @@ IN: units.tests : km/L km 1 L d/ ; : mpg miles 1 gallons d/ ; -[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test +! [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test From e95097dbdf721af44a6547b8fa1b83e75f3795ca Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 11 Mar 2008 11:44:03 +1100 Subject: [PATCH 02/14] semantic-db: now loads and passes tests --- extra/semantic-db/hierarchy/hierarchy.factor | 8 +++-- extra/semantic-db/semantic-db-tests.factor | 33 ++++++++++++++------ extra/semantic-db/semantic-db.factor | 1 + 3 files changed, 30 insertions(+), 12 deletions(-) diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index fa10fff01c..7d5f976909 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ; +USING: accessors db.tuples kernel new-slots semantic-db +semantic-db.relations sorting sequences sequences.deep ; IN: semantic-db.hierarchy TUPLE: tree id children ; @@ -33,6 +34,9 @@ C: tree : get-node-hierarchy ( node-id -- tree ) dup children [ get-node-hierarchy ] map ; +: uniq ( sorted-seq -- seq ) + f swap [ tuck = not ] subset nip ; + : (get-root-nodes) ( node-id -- root-nodes/node-id ) dup parents dup empty? [ drop @@ -41,4 +45,4 @@ C: tree ] if ; : get-root-nodes ( node-id -- root-nodes ) - (get-root-nodes) flatten ; + (get-root-nodes) flatten natural-sort uniq ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 01476a145a..6c2c4d3e9e 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,18 +1,27 @@ -USING: accessors arrays db db.sqlite db.tuples kernel math namespaces -semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations -sequences tools.test tools.walker ; +USING: accessors arrays continuations db db.sqlite db.tuples io.files +kernel math namespaces semantic-db semantic-db.context +semantic-db.hierarchy semantic-db.relations sequences tools.test +tools.walker ; IN: semantic-db.tests -[ +: db-path "semantic-db-test.db" temp-file ; +: test-db db-path sqlite-db ; +: delete-db [ db-path delete-file ] ignore-errors ; + +delete-db + +test-db [ create-node-table create-arc-table [ 1 ] [ "first node" create-node* ] unit-test [ 2 ] [ "second node" create-node* ] unit-test [ 3 ] [ "third node" create-node* ] unit-test [ 4 ] [ f create-node* ] unit-test [ 5 ] [ 1 2 3 create-arc* ] unit-test -] with-tmp-sqlite +] with-db -[ +delete-db + +test-db [ init-semantic-db "test content" create-context* [ [ 4 ] [ context ] unit-test @@ -35,10 +44,12 @@ IN: semantic-db.tests ! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test ! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test ! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test -] with-tmp-sqlite +] with-db + +delete-db ! test hierarchy -[ +test-db [ init-semantic-db "family tree" create-context* [ "adam" create-node* "adam" set @@ -52,7 +63,9 @@ IN: semantic-db.tests [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test - [ { "adam" "eve" } ] [ "charlie" get break get-root-nodes [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map ] unit-test [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test ] with-context -] with-tmp-sqlite +] with-db + +delete-db diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index a48048f152..e8075c016d 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -86,3 +86,4 @@ arc "arc" #! quot1 ( x y -- z/f ) finds an existing z #! quot2 ( x y -- z ) creates a new z if quot1 returns f >r >r 2dup r> call [ 2nip ] r> if* ; + From dcdee4ec6f2b86f444e0d536c9d2cf80cc785ff2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:30:14 -0500 Subject: [PATCH 03/14] Minor core features --- core/parser/parser.factor | 6 +++--- core/sequences/sequences.factor | 3 +++ core/splitting/splitting.factor | 6 +++--- 3 files changed, 9 insertions(+), 6 deletions(-) mode change 100644 => 100755 core/splitting/splitting.factor diff --git a/core/parser/parser.factor b/core/parser/parser.factor index cc84084258..1bdff49506 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -240,13 +240,13 @@ PREDICATE: unexpected unexpected-eof : CREATE ( -- word ) scan create-in ; -: create-class ( word vocab -- word ) - create +: create-class-in ( word vocab -- word ) + in get create dup save-class-location dup predicate-word dup set-word save-location ; : CREATE-CLASS ( -- word ) - scan in get create-class ; + scan create-class-in ; : word-restarts ( possibilities -- restarts ) natural-sort [ diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 7208e05af0..9fc5264440 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -441,6 +441,9 @@ PRIVATE> : memq? ( obj seq -- ? ) [ eq? ] with contains? ; +: seq-intersect ( seq1 seq2 -- seq1/\seq2 ) + swap [ member? ] curry subset ; + : remove ( obj seq -- newseq ) [ = not ] with subset ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor old mode 100644 new mode 100755 index c6230ebe16..6416e27eaf --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -69,12 +69,12 @@ INSTANCE: groups sequence : split ( seq separators -- pieces ) [ split, ] { } make ; : string-lines ( str -- seq ) - dup [ "\r\n" member? ] contains? [ + dup "\r\n" seq-intersect empty? [ + 1array + ] [ "\n" split [ 1 head-slice* [ "\r" ?tail drop "\r" split ] map ] keep peek "\r" split add concat - ] [ - 1array ] if ; From 9565a04e74f6e5d3a2d6c40b3278a0002d711198 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:30:35 -0500 Subject: [PATCH 04/14] Tiny fry fix --- extra/fry/fry.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index f8d49af163..490ce992ab 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences combinators parser splitting -quotations arrays namespaces ; +quotations arrays namespaces qualified ; +QUALIFIED: namespaces IN: fry : , "Only valid inside a fry" throw ; @@ -23,6 +24,10 @@ DEFER: (fry) unclip { { , [ [ curry ] ((fry)) ] } { @ [ [ compose ] ((fry)) ] } + + ! to avoid confusion, remove if fry goes core + { namespaces:, [ [ curry ] ((fry)) ] } + [ swap >r add r> (fry) ] } case ] if ; From 2c1e1d9a945615afa675006abe9142cdb18cc579 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:35:43 -0500 Subject: [PATCH 05/14] Rename smtp:send to smtp:send-email, simplify insomniac config --- extra/logging/insomniac/insomniac-docs.factor | 11 +------- extra/logging/insomniac/insomniac.factor | 27 ++++++------------- extra/smtp/server/server.factor | 4 +-- extra/smtp/smtp-tests.factor | 9 +++---- extra/smtp/smtp.factor | 23 +++++++--------- 5 files changed, 25 insertions(+), 49 deletions(-) diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor index 93485e4c7c..7529c3ba63 100755 --- a/extra/logging/insomniac/insomniac-docs.factor +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -2,12 +2,6 @@ USING: help.markup help.syntax assocs strings logging logging.analysis smtp ; IN: logging.insomniac -HELP: insomniac-smtp-host -{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ; - -HELP: insomniac-smtp-port -{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ; - HELP: insomniac-sender { $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; @@ -21,7 +15,7 @@ HELP: ?analyze-log HELP: email-log-report { $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } -{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; +{ $description "E-mails a log report for the given log service. The " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; HELP: schedule-insomniac { $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } @@ -33,9 +27,6 @@ $nl "Required configuration parameters:" { $subsection insomniac-sender } { $subsection insomniac-recipients } -"Optional configuration parameters:" -{ $subsection insomniac-smtp-host } -{ $subsection insomniac-smtp-port } "E-mailing a one-off report:" { $subsection email-log-report } "E-mailing reports and rotating logs on a daily basis:" diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index dfd7f430d2..c7d1faf42e 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -6,8 +6,6 @@ io.encodings.utf8 accessors calendar qualified ; QUALIFIED: io.sockets IN: logging.insomniac -SYMBOL: insomniac-smtp-host -SYMBOL: insomniac-smtp-port SYMBOL: insomniac-sender SYMBOL: insomniac-recipients @@ -18,29 +16,20 @@ SYMBOL: insomniac-recipients r> 2drop f ] if ; -: with-insomniac-smtp ( quot -- ) - [ - insomniac-smtp-host get [ smtp-host set ] when* - insomniac-smtp-port get [ smtp-port set ] when* - call - ] with-scope ; inline - : email-subject ( service -- string ) [ "[INSOMNIAC] " % % " on " % io.sockets:host-name % ] "" make ; : (email-log-report) ( service word-names -- ) - [ - dupd ?analyze-log dup [ - - swap >>body - insomniac-recipients get >>to - insomniac-sender get >>from - swap email-subject >>subject - send - ] [ 2drop ] if - ] with-insomniac-smtp ; + dupd ?analyze-log dup [ + + swap >>body + insomniac-recipients get >>to + insomniac-sender get >>from + swap email-subject >>subject + send-email + ] [ 2drop ] if ; \ (email-log-report) NOTICE add-error-logging diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index 92b605e91c..14957ceca2 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -6,7 +6,7 @@ IN: smtp.server ! Mock SMTP server for testing purposes. -! Usage: 4321 smtp-server +! Usage: 4321 mock-smtp-server ! $ telnet 127.0.0.1 4321 ! Trying 127.0.0.1... ! Connected to localhost. @@ -61,7 +61,7 @@ SYMBOL: data-mode ] } } cond nip [ process ] when ; -: smtp-server ( port -- ) +: mock-smtp-server ( port -- ) "Starting SMTP server on port " write dup . flush "127.0.0.1" swap ascii [ accept [ diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 76ceaceea4..a705a9609e 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,4 +1,4 @@ -USING: smtp tools.test io.streams.string threads +USING: smtp tools.test io.streams.string io.sockets threads smtp.server kernel sequences namespaces logging accessors assocs sorting ; IN: smtp.tests @@ -62,12 +62,11 @@ IN: smtp.tests rot from>> ] unit-test -[ ] [ [ 4321 smtp-server ] in-thread ] unit-test +[ ] [ [ 4321 mock-smtp-server ] in-thread ] unit-test [ ] [ [ - "localhost" smtp-host set - 4321 smtp-port set + "localhost" 4321 smtp-server set "Hi guys\nBye guys" >>body @@ -77,6 +76,6 @@ IN: smtp.tests "Ed " } >>to "Doug " >>from - send + send-email ] with-scope ] unit-test diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index b23d5e3798..a941b14a47 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -8,19 +8,16 @@ calendar.format new-slots accessors ; IN: smtp SYMBOL: smtp-domain -SYMBOL: smtp-host "localhost" smtp-host set-global -SYMBOL: smtp-port 25 smtp-port set-global +SYMBOL: smtp-server "localhost" 25 smtp-server set-global SYMBOL: read-timeout 1 minutes read-timeout set-global SYMBOL: esmtp t esmtp set-global -: log-smtp-connection ( host port -- ) 2drop ; - -\ log-smtp-connection NOTICE add-input-logging +LOG: log-smtp-connection NOTICE ( addrspec -- ) : with-smtp-connection ( quot -- ) - smtp-host get smtp-port get - 2dup log-smtp-connection - ascii [ + smtp-server get + dup log-smtp-connection + ascii [ smtp-domain [ host-name or ] change read-timeout get stdio get set-timeout call @@ -33,8 +30,8 @@ SYMBOL: esmtp t esmtp set-global : validate-address ( string -- string' ) #! Make sure we send funky stuff to the server by accident. - dup [ "\r\n>" member? ] contains? - [ "Bad e-mail address: " swap append throw ] when ; + dup "\r\n>" seq-intersect empty? + [ "Bad e-mail address: " swap append throw ] unless ; : mail-from ( fromaddr -- ) "MAIL FROM:<" write validate-address write ">" write crlf ; @@ -91,8 +88,8 @@ LOG: smtp-response DEBUG : get-ok ( -- ) flush receive-response check-response ; : validate-header ( string -- string' ) - dup [ "\r\n" member? ] contains? - [ "Invalid header string: " swap append throw ] when ; + dup "\r\n" seq-intersect empty? + [ "Invalid header string: " swap append throw ] unless ; : write-header ( key value -- ) swap @@ -153,7 +150,7 @@ M: email clone email construct-empty H{ } clone >>headers ; -: send ( email -- ) +: send-email ( email -- ) prepare (send) ; ! Dirk's old AUTH CRAM-MD5 code. I don't know anything about From 093ae20ed571b13d447e71fdd6badc9cbf011fd2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:35:59 -0500 Subject: [PATCH 06/14] Fix bug in regexp char class parser --- extra/regexp/regexp-tests.factor | 4 ++++ extra/regexp/regexp.factor | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index f6e7c05910..5a6b0bdfac 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -222,3 +222,7 @@ IN: regexp-tests [ f ] [ "foo bar" "foo\\B bar" f matches? ] unit-test [ t ] [ "fooxbar" "foo\\Bxbar" f matches? ] unit-test [ f ] [ "foo" "foo\\Bbar" f matches? ] unit-test + +[ t ] [ "s@f" "[a-z.-]@[a-z]" f matches? ] unit-test +[ f ] [ "a" "[a-z.-]@[a-z]" f matches? ] unit-test +[ t ] [ ".o" "\\.[a-z]" f matches? ] unit-test diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index fe1d87d9e9..8a642a8692 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -167,7 +167,8 @@ C: group-result "(" ")" surrounded-by ; : 'range' ( -- parser ) - any-char-parser "-" token <& any-char-parser <&> + [ CHAR: ] = not ] satisfy "-" token <& + [ CHAR: ] = not ] satisfy <&> [ first2 char-between?-quot ] <@ ; : 'character-class-term' ( -- parser ) From 2b00bafdc16cec9b2fe225bfee401796ba3aac4e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:36:09 -0500 Subject: [PATCH 07/14] Update singleton for core changes --- extra/singleton/singleton.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/singleton/singleton.factor diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor old mode 100644 new mode 100755 index 1451283f23..0b77443a50 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -5,7 +5,7 @@ sequences words ; IN: singleton : define-singleton ( token -- ) - \ word swap in get create-class + \ word swap create-class-in dup [ eq? ] curry define-predicate-class ; : SINGLETON: From a463e6d9fbb86f0df9255bd0a5c8163e36b2bf62 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:36:19 -0500 Subject: [PATCH 08/14] Moved seq-intersect to core --- extra/units/units.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/units/units.factor b/extra/units/units.factor index f7aad72545..13d0a5d1cf 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -12,9 +12,6 @@ TUPLE: dimensions-not-equal ; M: dimensions-not-equal summary drop "Dimensions do not match" ; -: seq-intersect ( seq1 seq2 -- seq1/\seq2 ) - swap [ member? ] curry subset ; - : remove-one ( seq obj -- seq ) 1array split1 append ; From dfacba5f3bd37e7888a20f3fb4532656b170ae98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:36:33 -0500 Subject: [PATCH 09/14] Clean up erg's change --- core/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 1bdff49506..81c9b68668 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -240,7 +240,7 @@ PREDICATE: unexpected unexpected-eof : CREATE ( -- word ) scan create-in ; -: create-class-in ( word vocab -- word ) +: create-class-in ( word -- word ) in get create dup save-class-location dup predicate-word dup set-word save-location ; From 60cf3950328ae5e76f2056c0e4f080ae12902913 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:37:45 -0500 Subject: [PATCH 10/14] Fix keyboard shortcut --- extra/ui/tools/tools.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 062bcf9416..b98b1dba28 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -66,7 +66,7 @@ workspace "tool-switching" f { { T{ key-down f { A+ } "1" } com-listener } { T{ key-down f { A+ } "2" } com-browser } { T{ key-down f { A+ } "3" } com-inspector } - { T{ key-down f { A+ } "5" } com-profiler } + { T{ key-down f { A+ } "4" } com-profiler } } define-command-map \ workspace-window From 2b150db9b9ceb27b37853148f858539b1ca05d17 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:39:09 -0500 Subject: [PATCH 11/14] HTTP server work in progress --- extra/http/client/client.factor | 7 +- extra/http/http-tests.factor | 4 +- extra/http/http.factor | 18 +- .../http/server/actions/actions-tests.factor | 6 +- extra/http/server/actions/actions.factor | 66 ++-- extra/http/server/auth/auth.factor | 8 + .../http/server/auth/login/login-tests.factor | 6 + extra/http/server/auth/login/login.factor | 333 +++++++++++++++--- extra/http/server/auth/login/login.fhtml | 22 +- extra/http/server/auth/login/recover-1.fhtml | 38 ++ extra/http/server/auth/login/recover-2.fhtml | 9 + extra/http/server/auth/login/recover-3.fhtml | 43 +++ extra/http/server/auth/login/recover-4.fhtml | 10 + extra/http/server/auth/login/register.fhtml | 75 ++++ .../auth/providers/assoc/assoc-tests.factor | 31 +- .../server/auth/providers/assoc/assoc.factor | 22 +- .../server/auth/providers/db/db-tests.factor | 33 +- extra/http/server/auth/providers/db/db.factor | 56 ++- .../server/auth/providers/null/null.factor | 12 +- .../server/auth/providers/providers.factor | 54 ++- .../server/callbacks/callbacks-tests.factor | 64 ++++ extra/http/server/callbacks/callbacks.factor | 80 ++--- extra/http/server/cgi/cgi.factor | 14 +- .../server/components/components-tests.factor | 88 +++++ .../http/server/components/components.factor | 253 +++++++++---- .../server/components/farkup/farkup.factor | 13 + extra/http/server/components/test/form.fhtml | 1 + extra/http/server/crud/crud.factor | 72 +++- extra/http/server/db/db.factor | 10 +- extra/http/server/server-tests.factor | 34 +- extra/http/server/server.factor | 152 +++++--- .../server/sessions/sessions-tests.factor | 4 +- extra/http/server/sessions/sessions.factor | 79 +++-- extra/http/server/static/static.factor | 49 +-- .../templating/fhtml/fhtml-tests.factor | 8 +- .../http/server/templating/fhtml/fhtml.factor | 33 +- .../server/validators/validators-tests.factor | 22 +- .../http/server/validators/validators.factor | 39 +- extra/xmode/code2html/code2html.factor | 13 +- .../code2html/responder/responder.factor | 20 +- 40 files changed, 1419 insertions(+), 482 deletions(-) mode change 100644 => 100755 extra/http/server/actions/actions-tests.factor create mode 100755 extra/http/server/auth/auth.factor create mode 100755 extra/http/server/auth/login/login-tests.factor create mode 100755 extra/http/server/auth/login/recover-1.fhtml create mode 100755 extra/http/server/auth/login/recover-2.fhtml create mode 100755 extra/http/server/auth/login/recover-3.fhtml create mode 100755 extra/http/server/auth/login/recover-4.fhtml create mode 100755 extra/http/server/auth/login/register.fhtml create mode 100755 extra/http/server/callbacks/callbacks-tests.factor create mode 100755 extra/http/server/components/components-tests.factor create mode 100755 extra/http/server/components/farkup/farkup.factor create mode 100755 extra/http/server/components/test/form.fhtml mode change 100644 => 100755 extra/http/server/crud/crud.factor mode change 100644 => 100755 extra/http/server/validators/validators-tests.factor mode change 100644 => 100755 extra/http/server/validators/validators.factor diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 0d733ba97d..ee0d5f7f3b 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting calendar continuations accessors vectors io.encodings.latin1 -io.encodings.binary ; +splitting calendar continuations accessors vectors +io.encodings.latin1 io.encodings.binary fry ; IN: http.client DEFER: http-request @@ -46,8 +46,7 @@ DEFER: http-request dup host>> swap port>> ; : close-on-error ( stream quot -- ) - [ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ; - inline + '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline PRIVATE> diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 16be0d026d..66182b10ae 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -137,10 +137,10 @@ io.encodings.ascii ; [ - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>get + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display "quit" add-responder "extra/http/test" resource-path >>default - default-host set + main-responder set [ 1237 httpd ] "HTTPD test" spawn drop ] with-scope diff --git a/extra/http/http.factor b/extra/http/http.factor index 849b9e2fc9..c72a631d16 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io io.streams.string kernel math namespaces -math.parser assocs sequences strings splitting ascii -io.encodings.utf8 io.encodings.string namespaces -unicode.case combinators vectors sorting new-slots accessors -calendar calendar.format quotations arrays ; +USING: fry hashtables io io.streams.string kernel math +namespaces math.parser assocs sequences strings splitting ascii +io.encodings.utf8 io.encodings.string namespaces unicode.case +combinators vectors sorting new-slots accessors calendar +calendar.format quotations arrays ; IN: http : http-port 80 ; inline @@ -91,8 +91,8 @@ IN: http : check-header-string ( str -- str ) #! http://en.wikipedia.org/wiki/HTTP_Header_Injection - dup [ "\r\n" member? ] contains? - [ "Header injection attack" throw ] when ; + dup "\r\n" seq-intersect empty? + [ "Header injection attack" throw ] unless ; : write-header ( assoc -- ) >alist sort-keys [ @@ -396,13 +396,13 @@ M: response write-full-response ( request response -- ) "content-type" set-header ; : get-cookie ( request/response name -- cookie/f ) - >r cookies>> r> [ swap name>> = ] curry find nip ; + >r cookies>> r> '[ , _ name>> = ] find nip ; : delete-cookie ( request/response name -- ) over cookies>> >r get-cookie r> delete ; : put-cookie ( request/response cookie -- request/response ) - [ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep + [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep over cookies>> push ; TUPLE: raw-response diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor old mode 100644 new mode 100755 index 13089ae6e8..98a92e083a --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -4,7 +4,7 @@ multiline namespaces http io.streams.string http.server sequences accessors ; - [ "a" get "b" get + ] >>get + [ "a" get "b" get + ] >>display { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params "action-1" set @@ -16,12 +16,13 @@ blah [ 25 ] [ action-request-test-1 [ read-request ] with-string-reader + request set "/blah" "action-1" get call-responder ] unit-test - [ +path+ get "xxx" get "X" concat append ] >>post + [ +path+ get "xxx" get "X" concat append ] >>submit { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params "action-2" set @@ -34,6 +35,7 @@ xxx=4 [ "/blahXXXX" ] [ action-request-test-2 [ read-request ] with-string-reader + request set "/blah" "action-2" get call-responder ] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 5e5b7a9563..bab55eef0c 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,41 +1,61 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors new-slots sequences kernel assocs combinators -http.server http.server.validators http hashtables namespaces ; +http.server http.server.validators http hashtables namespaces +combinators.cleave fry continuations ; IN: http.server.actions SYMBOL: +path+ -TUPLE: action get get-params post post-params revalidate ; +SYMBOL: params + +TUPLE: action init display submit get-params post-params ; : action construct-empty - [ <400> ] >>get - [ <400> ] >>post - [ <400> ] >>revalidate ; + [ ] >>init + [ <400> ] >>display + [ <400> ] >>submit ; -: extract-params ( request path -- assoc ) - >r dup method>> { +: extract-params ( path -- assoc ) + +path+ associate + request get dup method>> { { "GET" [ query>> ] } + { "HEAD" [ query>> ] } { "POST" [ post-data>> query>assoc ] } - } case r> +path+ associate union ; + } case union ; -: action-params ( request path param -- error? ) - -rot extract-params validate-params ; +: with-validator ( string quot -- result error? ) + '[ , @ f ] [ + dup validation-error? [ t ] [ rethrow ] if + ] recover ; inline -: get-action ( request path -- response ) - action get get-params>> action-params - [ <400> ] [ action get get>> call ] if ; +: validate-param ( name validator assoc -- error? ) + swap pick + >r >r at r> with-validator swap r> set ; -: post-action ( request path -- response ) +: action-params ( validators -- error? ) + [ params get validate-param ] { } assoc>map [ ] contains? ; + +: handle-get ( -- response ) + action get get-params>> action-params [ <400> ] [ + action get [ init>> call ] [ display>> call ] bi + ] if ; + +: handle-post ( -- response ) action get post-params>> action-params - [ action get revalidate>> ] [ action get post>> ] if call ; + [ <400> ] [ action get submit>> call ] if ; -M: action call-responder ( request path action -- response ) - action set - over request set - over method>> - { - { "GET" [ get-action ] } - { "POST" [ post-action ] } - } case ; +: validation-failed ( -- * ) + action get display>> call exit-with ; + +M: action call-responder ( path action -- response ) + [ extract-params params set ] + [ + action set + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] bi* ; diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor new file mode 100755 index 0000000000..a9645693fb --- /dev/null +++ b/extra/http/server/auth/auth.factor @@ -0,0 +1,8 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: http.server.sessions accessors ; +IN: http.server.auth + +SYMBOL: logged-in-user + +: uid ( -- string ) logged-in-user sget username>> ; diff --git a/extra/http/server/auth/login/login-tests.factor b/extra/http/server/auth/login/login-tests.factor new file mode 100755 index 0000000000..b69630a930 --- /dev/null +++ b/extra/http/server/auth/login/login-tests.factor @@ -0,0 +1,6 @@ +IN: http.server.auth.login.tests +USING: tools.test http.server.auth.login ; + +\ must-infer +\ allow-registration must-infer +\ allow-password-recovery must-infer diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index e2f9a3608a..7d92c727c6 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -2,68 +2,299 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors new-slots quotations assocs kernel splitting base64 html.elements io combinators http.server -http.server.auth.providers http.server.actions -http.server.sessions http.server.templating.fhtml http sequences -io.files namespaces ; +http.server.auth.providers http.server.auth.providers.null +http.server.actions http.server.components http.server.sessions +http.server.templating.fhtml http.server.validators +http.server.auth http sequences io.files namespaces hashtables +fry io.sockets combinators.cleave arrays threads locals +qualified ; IN: http.server.auth.login +QUALIFIED: smtp -TUPLE: login-auth responder provider ; +TUPLE: login users ; -C: (login-auth) login-auth - -SYMBOL: logged-in? -SYMBOL: provider SYMBOL: post-login-url +SYMBOL: login-failed? -: login-page ( -- response ) - "text/html" [ - "extra/http/server/auth/login/login.fhtml" - resource-path run-template-file - ] >>body ; +! ! ! Login -: - - [ login-page ] >>get +: + "login"
+ "resource:extra/http/server/auth/login/login.fhtml" >>edit-template + "username" + t >>required + add-field + "password" + t >>required + add-field ; - { - { "name" [ ] } - { "password" [ ] } - } >>post-params +: successful-login ( user -- response ) + logged-in-user sset + post-login-url sget f ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + "password" value "username" value + login get users>> check-login [ + successful-login + ] [ + login-failed? on + validation-failed + ] if* + ] >>submit + ] ; + +! ! ! New user registration + +: ( -- form ) + "register" + "resource:extra/http/server/auth/login/register.fhtml" >>edit-template + "username" + t >>required + add-field + "realname" add-field + "password" + t >>required + add-field + "verify-password" + t >>required + add-field + "email" add-field + "captcha" add-field ; + +SYMBOL: password-mismatch? +SYMBOL: user-exists? + +: same-password-twice ( -- ) + "password" value "verify-password" value = [ + password-mismatch? on + validation-failed + ] unless ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + same-password-twice + + values get [ + "username" get >>username + "realname" get >>realname + "password" get >>password + "email" get >>email + ] bind + + login get users>> new-user [ + user-exists? on + validation-failed + ] unless* + + successful-login + ] >>submit + ] ; + +! ! ! Password recovery + +SYMBOL: lost-password-from + +: current-host ( -- string ) + request get host>> host-name or ; + +: new-password-url ( user -- url ) + "new-password" + swap [ + [ username>> "username" set ] + [ ticket>> "ticket" set ] + bi + ] H{ } make-assoc + derive-url ; + +: password-email ( user -- email ) + smtp: + [ "[ " % current-host % " ] password recovery" % ] "" make >>subject + lost-password-from get >>from + over email>> 1array >>to [ - "password" get - "name" get - provider sget check-login [ - t logged-in? sset - post-login-url sget - ] [ - login-page - ] if - ] >>post ; + "This e-mail was sent by the application server on " % current-host % "\n" % + "because somebody, maybe you, clicked on a ``recover password'' link in the\n" % + "login form, and requested a new password for the user named ``" % + over username>> % "''.\n" % + "\n" % + "If you believe that this request was legitimate, you may click the below link in\n" % + "your browser to set a new password for your account:\n" % + "\n" % + swap new-password-url % + "\n\n" % + "Love,\n" % + "\n" % + " FactorBot\n" % + ] "" make >>body ; -: +: send-password-email ( user -- ) + '[ , password-email smtp:send-email ] + "E-mail send thread" spawn drop ; + +: ( -- form ) + "register" + "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template + "username" + t >>required + add-field + "email" + t >>required + add-field + "captcha" add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + "email" value "username" value + login get users>> issue-ticket [ + send-password-email + ] when* + + "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template + ] >>submit + ] ; + +: + "new-password" + "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template + "username" + t >>required + add-field + "password" + t >>required + add-field + "verify-password" + t >>required + add-field + "ticket" + t >>required + add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ + { "username" [ v-required ] } + { "ticket" [ v-required ] } + ] >>get-params + + [ + [ + "username" [ get ] keep set + "ticket" [ get ] keep set + ] H{ } make-assoc values set + ] >>init + + [ + "text/html" + [ edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + same-password-twice + + "ticket" value + "username" value + login get users>> claim-ticket [ + "password" value >>password + login get users>> update-user + + "resource:extra/http/server/auth/login/recover-4.fhtml" + serve-template + ] [ + <400> + ] if* + ] >>submit + ] ; + +! ! ! Logout +: ( -- action ) [ - f logged-in? sset - request get "login" - ] >>post ; + f logged-in-user sset + "login" f + ] >>submit ; -M: login-auth call-responder ( request path responder -- response ) - logged-in? sget - [ responder>> call-responder ] [ - pick method>> "GET" = [ - nip - provider>> provider sset - dup request-url post-login-url sset - "login" f session-link - ] [ - 3drop <400> - ] if +! ! ! Authentication logic + +TUPLE: protected responder ; + +C: protected + +M: protected call-responder ( path responder -- response ) + logged-in-user sget [ responder>> call-responder ] [ + 2drop + request get method>> { "GET" "HEAD" } member? [ + request get request-url post-login-url sset + "login" f + ] [ <400> ] if ] if ; -: ( responder provider -- auth ) - (login-auth) - - swap >>default - "login" add-responder - "logout" add-responder - ; +M: login call-responder ( path responder -- response ) + dup login set + delegate call-responder ; + +: ( responder -- auth ) + login + swap >>default + "login" add-responder + "logout" add-responder + no >>users ; + +! ! ! Configuration + +: allow-registration ( login -- login ) + "register" add-responder ; + +: allow-password-recovery ( login -- login ) + "recover-password" add-responder + "new-password" add-responder ; + +: allow-registration? ( -- ? ) + login get responders>> "register" swap key? ; + +: allow-password-recovery? ( -- ? ) + login get responders>> "recover-password" swap key? ; diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml index 9bb1438588..8e879420a9 100755 --- a/extra/http/server/auth/login/login.fhtml +++ b/extra/http/server/auth/login/login.fhtml @@ -1,3 +1,5 @@ +<% USING: http.server.auth.login http.server.components kernel +namespaces ; %>

Login required

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

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

+

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

+ diff --git a/extra/http/server/auth/login/recover-1.fhtml b/extra/http/server/auth/login/recover-1.fhtml new file mode 100755 index 0000000000..3e8448f64b --- /dev/null +++ b/extra/http/server/auth/login/recover-1.fhtml @@ -0,0 +1,38 @@ +<% USING: http.server.components ; %> + + +

Recover lost password: step 1 of 4

+ +

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

+ +
+ + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-edit %>
E-mail:<% "email" component render-edit %>
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
+ + + +
+ + + diff --git a/extra/http/server/auth/login/recover-2.fhtml b/extra/http/server/auth/login/recover-2.fhtml new file mode 100755 index 0000000000..9b13734273 --- /dev/null +++ b/extra/http/server/auth/login/recover-2.fhtml @@ -0,0 +1,9 @@ +<% USING: http.server.components ; %> + + +

Recover lost password: step 2 of 4

+ +

If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.

+ + + diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml new file mode 100755 index 0000000000..b220cc4f75 --- /dev/null +++ b/extra/http/server/auth/login/recover-3.fhtml @@ -0,0 +1,43 @@ +<% USING: http.server.components http.server.auth.login +namespaces kernel combinators ; %> + + +

Recover lost password: step 3 of 4

+ +

Choose a new password for your account.

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

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

+ +
+ + + diff --git a/extra/http/server/auth/login/recover-4.fhtml b/extra/http/server/auth/login/recover-4.fhtml new file mode 100755 index 0000000000..dec7a5404f --- /dev/null +++ b/extra/http/server/auth/login/recover-4.fhtml @@ -0,0 +1,10 @@ +<% USING: http.server.components http.server.auth.login +namespaces kernel combinators ; %> + + +

Recover lost password: step 4 of 4

+ +

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

+ + + diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml new file mode 100755 index 0000000000..c7e274e626 --- /dev/null +++ b/extra/http/server/auth/login/register.fhtml @@ -0,0 +1,75 @@ +<% USING: http.server.components http.server.auth.login +namespaces kernel combinators ; %> + + +

New user registration

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

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

+ +
+ + + diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index 3270fe06e3..12c799816d 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -1,18 +1,33 @@ IN: http.server.auth.providers.assoc.tests USING: http.server.auth.providers http.server.auth.providers.assoc tools.test -namespaces ; +namespaces accessors kernel ; - "provider" set + "provider" set -"slava" "provider" get new-user +[ t ] [ + + "slava" >>username + "foobar" >>password + "slava@factorcode.org" >>email + "provider" get new-user + username>> "slava" = +] unit-test -[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with +[ f ] [ + + "slava" >>username + "provider" get new-user +] unit-test -[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test +[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test -[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with +[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test -"fdasf" "slava" "provider" get set-password +[ f ] [ "xx" "blah" "provider" get set-password ] unit-test -[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test +[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test + +[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + +[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor index d57be622c7..8433e54fda 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -4,20 +4,16 @@ IN: http.server.auth.providers.assoc USING: new-slots accessors assocs kernel http.server.auth.providers ; -TUPLE: assoc-auth-provider assoc ; +TUPLE: in-memory assoc ; -: ( -- provider ) - H{ } clone assoc-auth-provider construct-boa ; +: ( -- provider ) + H{ } clone in-memory construct-boa ; -M: assoc-auth-provider check-login - assoc>> at = ; +M: in-memory get-user ( username provider -- user/f ) + assoc>> at ; -M: assoc-auth-provider new-user - assoc>> - 2dup key? [ drop user-exists ] when - t -rot set-at ; +M: in-memory update-user ( user provider -- ) 2drop ; -M: assoc-auth-provider set-password - assoc>> - 2dup key? [ drop no-such-user ] unless - set-at ; +M: in-memory new-user ( user provider -- user/f ) + >r dup username>> r> assoc>> + 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index c4682c2051..247359aea4 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -2,24 +2,39 @@ IN: http.server.auth.providers.db.tests USING: http.server.auth.providers http.server.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations -io.files ; +io.files accessors kernel ; -db-auth-provider "provider" set +from-db "provider" set "auth-test.db" temp-file sqlite-db [ - + [ user drop-table ] ignore-errors [ user create-table ] ignore-errors - "slava" "provider" get new-user + [ t ] [ + + "slava" >>username + "foobar" >>password + "slava@factorcode.org" >>email + "provider" get new-user + username>> "slava" = + ] unit-test - [ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + [ f ] [ + + "slava" >>username + "provider" get new-user + ] unit-test - [ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test - [ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + [ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test - "fdasf" "slava" "provider" get set-password + [ f ] [ "xx" "blah" "provider" get set-password ] unit-test - [ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test + [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test + + [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + + [ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test ] with-db diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index 9583122875..e9e79ff82f 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -1,53 +1,45 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db db.tuples db.types new-slots accessors -http.server.auth.providers kernel ; +http.server.auth.providers kernel continuations ; IN: http.server.auth.providers.db -TUPLE: user name password ; - -: user construct-empty ; - user "USERS" { - { "name" "NAME" { VARCHAR 256 } +assigned-id+ } + { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ } + { "realname" "REALNAME" { VARCHAR 256 } } { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } + { "email" "EMAIL" { VARCHAR 256 } } + { "ticket" "TICKET" { VARCHAR 256 } } + { "profile" "PROFILE" FACTOR-BLOB } } define-persistent : init-users-table ( -- ) + [ user drop-table ] ignore-errors user create-table ; -TUPLE: db-auth-provider ; +TUPLE: from-db ; -: db-auth-provider T{ db-auth-provider } ; +: from-db T{ from-db } ; -M: db-auth-provider check-login - drop +: find-user ( username -- user ) - swap >>name - swap >>password - select-tuple >boolean ; + swap >>username + select-tuple ; -M: db-auth-provider new-user +M: from-db get-user + drop + find-user ; + +M: from-db new-user drop [ - - swap >>name - - dup select-tuple [ name>> user-exists ] when - - "unassigned" >>password - - insert-tuple + dup username>> find-user [ + drop f + ] [ + dup insert-tuple + ] if ] with-transaction ; -M: db-auth-provider set-password - drop - [ - - swap >>name - - dup select-tuple [ ] [ no-such-user ] ?if - - swap >>password update-tuple - ] with-transaction ; +M: from-db update-user + drop update-tuple ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor index 702111972e..7b8bfc627c 100755 --- a/extra/http/server/auth/providers/null/null.factor +++ b/extra/http/server/auth/providers/null/null.factor @@ -3,12 +3,14 @@ USING: http.server.auth.providers kernel ; IN: http.server.auth.providers.null -TUPLE: null-auth-provider ; +! Named "no" because we can say no >>users -: null-auth-provider T{ null-auth-provider } ; +TUPLE: no ; -M: null-auth-provider check-login 3drop f ; +: no T{ no } ; -M: null-auth-provider new-user 3drop f ; +M: no get-user 2drop f ; -M: null-auth-provider set-password 3drop f ; +M: no new-user 2drop f ; + +M: no update-user 2drop ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index 1e0fd33a67..08b71432cd 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -1,18 +1,56 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ; +USING: kernel new-slots accessors random math.parser locals +sequences math ; IN: http.server.auth.providers -GENERIC: check-login ( password user provider -- ? ) +TUPLE: user username realname password email ticket profile ; -GENERIC: new-user ( user provider -- ) +: user construct-empty H{ } clone >>profile ; -GENERIC: set-password ( password user provider -- ) +GENERIC: get-user ( username provider -- user/f ) -TUPLE: user-exists name ; +GENERIC: update-user ( user provider -- ) -: user-exists ( name -- * ) \ user-exists construct-boa throw ; +GENERIC: new-user ( user provider -- user/f ) -TUPLE: no-such-user name ; +: check-login ( password username provider -- user/f ) + get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; -: no-such-user ( name -- * ) \ no-such-user construct-boa throw ; +:: set-password ( password username provider -- ) + [let | user [ username provider get-user ] | + user [ + user + password >>password + provider update-user t + ] [ f ] if + ] ; + +! Password recovery support + +:: issue-ticket ( email username provider -- user/f ) + [let | user [ username provider get-user ] | + user [ + user email>> length 0 > [ + user email>> email = [ + user + random-256 >hex >>ticket + dup provider update-user + ] [ f ] if + ] [ f ] if + ] [ f ] if + ] ; + +:: claim-ticket ( ticket username provider -- user/f ) + [let | user [ username provider get-user ] | + user [ + user ticket>> ticket = [ + user f >>ticket dup provider update-user + ] [ f ] if + ] [ f ] if + ] ; + +! For configuration + +: add-user ( provider user -- provider ) + over new-user [ "User exists" throw ] when ; diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor new file mode 100755 index 0000000000..4397ee5d15 --- /dev/null +++ b/extra/http/server/callbacks/callbacks-tests.factor @@ -0,0 +1,64 @@ +IN: http.server.callbacks +USING: http.server.actions http.server.callbacks accessors +http.server http tools.test namespaces io fry sequences +splitting kernel hashtables continuations ; + +[ 123 ] [ + [ + "GET" >>method request set + [ + exit-continuation set + "xxx" + [ [ "hello" print 123 ] show-final ] >>get + + call-responder + ] callcc1 + ] with-scope +] unit-test + +[ + [ + [ + "hello" print + "text/html" swap '[ , write ] >>body + ] show-page + "byebye" print + [ 123 ] show-final + ] >>get + "r" set + + [ 123 ] [ + [ + exit-continuation set + "GET" >>method request set + "" "r" get call-responder + ] callcc1 + + body>> first + + + "GET" >>method + swap cont-id associate >>query + "/" >>path + request set + + [ + exit-continuation set + "/" + "r" get call-responder + ] callcc1 + + ! get-post-get + + "GET" >>method + swap "location" header "=" last-split1 nip cont-id associate >>query + "/" >>path + request set + + [ + exit-continuation set + "/" + "r" get call-responder + ] callcc1 + ] unit-test +] with-scope diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index fd2e8f8ad7..ac03e0efc8 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -3,7 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: html http http.server io kernel math namespaces continuations calendar sequences assocs new-slots hashtables -accessors arrays alarms quotations combinators ; +accessors arrays alarms quotations combinators +combinators.cleave fry ; IN: http.server.callbacks SYMBOL: responder @@ -21,57 +22,45 @@ TUPLE: callback cont quot expires alarm responder ; : timeout 20 minutes ; : timeout-callback ( callback -- ) - dup alarm>> cancel-alarm - dup responder>> callbacks>> delete-at ; + [ alarm>> cancel-alarm ] + [ dup responder>> callbacks>> delete-at ] + bi ; : touch-callback ( callback -- ) dup expires>> [ dup alarm>> [ cancel-alarm ] when* - dup [ timeout-callback ] curry timeout later >>alarm + dup '[ , timeout-callback ] timeout later >>alarm ] when drop ; : ( cont quot expires? -- callback ) - [ f responder get callback construct-boa ] keep - [ dup touch-callback ] when ; + f callback-responder get callback construct-boa + dup touch-callback ; -: invoke-callback ( request exit-cont callback -- response ) - [ quot>> 3array ] keep cont>> continue-with ; +: invoke-callback ( callback -- response ) + [ touch-callback ] + [ quot>> request get exit-continuation get 3array ] + [ cont>> continue-with ] + tri ; : register-callback ( cont quot expires? -- id ) - - responder get callbacks>> generate-key - [ responder get callbacks>> set-at ] keep ; + callback-responder get callbacks>> set-at-unique ; -SYMBOL: exit-continuation - -: exit-with exit-continuation get continue-with ; - -: forward-to-url ( url -- * ) +: forward-to-url ( url query -- * ) #! When executed inside a 'show' call, this will force a #! HTTP 302 to occur to instruct the browser to forward to #! the request URL. - request get swap exit-with ; + exit-with ; : cont-id "factorcontid" ; -: id>url ( id -- url ) - request get - swap cont-id associate >>query - request-url ; - : forward-to-id ( id -- * ) #! When executed inside a 'show' call, this will force a #! HTTP 302 to occur to instruct the browser to forward to #! the request URL. - id>url forward-to-url ; + f swap cont-id associate forward-to-url ; : restore-request ( pair -- ) - first3 >r exit-continuation set request set r> call ; - -: resume-page ( request page responder callback -- * ) - dup touch-callback - >r 2drop exit-continuation get - r> invoke-callback ; + first3 exit-continuation set request set call ; SYMBOL: post-refresh-get? @@ -102,34 +91,27 @@ SYMBOL: current-show [ restore-request store-current-show ] when* ; : show-final ( quot -- * ) - >r redirect-to-here store-current-show - r> call exit-with ; inline + >r redirect-to-here store-current-show r> + call exit-with ; inline -M: callback-responder call-responder - [ - [ - exit-continuation set - dup responder set - pick request set - pick cont-id query-param over callbacks>> at [ - resume-page - ] [ - responder>> call-responder - "Continuation responder pages must use show-final" throw - ] if* - ] with-scope - ] callcc1 >r 3drop r> ; +: resuming-callback ( responder request -- id ) + cont-id query-param swap callbacks>> at ; + +M: callback-responder call-responder ( path responder -- response ) + [ callback-responder set ] + [ request get resuming-callback ] bi + + [ invoke-callback ] + [ callback-responder get responder>> call-responder ] ?if ; : show-page ( quot -- ) >r redirect-to-here store-current-show r> [ - [ ] register-callback - with-scope - exit-with + [ ] t register-callback swap call exit-with ] callcc1 restore-request ; inline : quot-id ( quot -- id ) current-show get swap t register-callback ; : quot-url ( quot -- url ) - quot-id id>url ; + quot-id f swap cont-id associate derive-url ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index cce3e5402d..509943faa8 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs io.files combinators arrays io.launcher io http.server.static http.server -http accessors sequences strings math.parser ; +http accessors sequences strings math.parser fry ; IN: http.server.cgi : post? request get method>> "POST" = ; @@ -45,19 +45,17 @@ IN: http.server.cgi over 1array >>command swap cgi-variables >>environment ; - + : serve-cgi ( name -- response ) 200 >>code "CGI output follows" >>message - swap [ - stdio get swap [ - post? [ - request get post-data>> write flush - ] when + swap '[ + , stdio get swap [ + post? [ request get post-data>> write flush ] when stdio get swap (stream-copy) ] with-stream - ] curry >>body ; + ] >>body ; : enable-cgi ( responder -- responder ) [ serve-cgi ] "application/x-cgi-script" diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor new file mode 100755 index 0000000000..2a507e6416 --- /dev/null +++ b/extra/http/server/components/components-tests.factor @@ -0,0 +1,88 @@ +IN: http.server.components.tests +USING: http.server.components http.server.validators +namespaces tools.test kernel accessors new-slots +tuple-syntax mirrors http.server.actions ; + +validation-failed? off + +[ 3 ] [ "3" "n" validate ] unit-test + +[ 123 ] [ + "" + "n" + 123 >>default + validate +] unit-test + +[ f ] [ validation-failed? get ] unit-test + +[ t ] [ "3x" "n" validate validation-error? ] unit-test + +[ t ] [ validation-failed? get ] unit-test + +[ "" ] [ "" "email" validate ] unit-test + +[ "slava@jedit.org" ] [ "slava@jedit.org" "email" validate ] unit-test + +[ "slava@jedit.org" ] [ + "slava@jedit.org" + "email" + t >>required + validate +] unit-test + +[ t ] [ + "a" + "email" + t >>required + validate validation-error? +] unit-test + +[ t ] [ "a" "email" validate validation-error? ] unit-test + +TUPLE: test-tuple text number more-text ; + +: test-tuple construct-empty ; + +: ( -- form ) + "test"
+ "resource:extra/http/server/components/test/form.fhtml" >>view-template + "resource:extra/http/server/components/test/form.fhtml" >>edit-template + "text" + t >>required + add-field + "number" + 123 >>default + t >>required + 0 >>min-value + 10 >>max-value + add-field + "more-text" + "hi" >>default + add-field ; + +[ ] [ values set view-form ] unit-test + +[ ] [ values set edit-form ] unit-test + +[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [ + from-tuple + set-defaults + values-tuple +] unit-test + +[ + H{ + { "text" "fdafsa" } + { "number" "xxx" } + { "more-text" "" } + } params set + + H{ } clone values set + + [ t ] [ (validate-form) ] unit-test + + [ "fdafsa" ] [ "text" value ] unit-test + + [ t ] [ "number" value validation-error? ] unit-test +] with-scope diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index f14b766910..bb0fc4b3dd 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,20 +1,23 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: new-slots html.elements http.server.validators -accessors namespaces kernel io farkup math.parser assocs -classes words tuples arrays sequences io.files -http.server.templating.fhtml splitting mirrors ; +USING: new-slots html.elements http.server.validators accessors +namespaces kernel io math.parser assocs classes words tuples +arrays sequences io.files http.server.templating.fhtml +http.server.actions splitting mirrors hashtables +combinators.cleave fry continuations math ; IN: http.server.components +SYMBOL: validation-failed? + SYMBOL: components -TUPLE: component id ; +TUPLE: component id required default ; : component ( name -- component ) dup components get at [ ] [ "No such component: " swap append throw ] ?if ; -GENERIC: validate* ( string component -- result ) +GENERIC: validate* ( value component -- result ) GENERIC: render-view* ( value component -- ) GENERIC: render-edit* ( value component -- ) GENERIC: render-error* ( reason value component -- ) @@ -23,47 +26,203 @@ SYMBOL: values : value values get at ; +: set-value values get set-at ; + +: validate ( value component -- result ) + '[ + , , + over empty? [ + [ default>> [ v-default ] when* ] + [ required>> [ v-required ] when ] + bi + ] [ validate* ] if + ] [ + dup validation-error? + [ validation-failed? on ] [ rethrow ] if + ] recover ; + : render-view ( component -- ) - dup id>> value swap render-view* ; + [ id>> value ] [ render-view* ] bi ; : render-error ( error -- ) write ; : render-edit ( component -- ) dup id>> value dup validation-error? [ - dup reason>> swap value>> rot render-error* + [ reason>> ] [ value>> ] bi rot render-error* ] [ - swap render-edit* + swap [ default>> or ] keep render-edit* ] if ; -: ( id string -- component ) - >r \ component construct-boa r> construct-delegate ; inline +: ( id class -- component ) + \ component construct-empty + swap construct-delegate + swap >>id ; inline -TUPLE: string min max ; +! Forms +TUPLE: form view-template edit-template components ; + +: ( id -- form ) + form + V{ } clone >>components ; + +: add-field ( form component -- form ) + dup id>> pick components>> set-at ; + +: with-form ( form quot -- ) + >r components>> components r> with-variable ; inline + +: set-defaults ( form -- ) + [ + components get [ + swap values get [ + swap default>> or + ] change-at + ] assoc-each + ] with-form ; + +: view-form ( form -- ) + dup view-template>> '[ , run-template ] with-form ; + +: edit-form ( form -- ) + dup edit-template>> '[ , run-template ] with-form ; + +: validate-param ( id component -- ) + [ [ params get at ] [ validate ] bi* ] + [ drop set-value ] 2bi ; + +: (validate-form) ( form -- error? ) + [ + validation-failed? off + components get [ validate-param ] assoc-each + validation-failed? get + ] with-form ; + +: validate-form ( form -- ) + (validate-form) [ validation-failed ] when ; + +: blank-values H{ } clone values set ; + +: from-tuple values set ; + +: values-tuple values get mirror-object ; + +! ! ! +! Canned components: for simple applications and prototyping +! ! ! + +: render-input ( value component type -- ) + > [ =id ] [ =name ] bi + =value + input/> ; + +! Hidden fields +TUPLE: hidden ; + +: ( component -- component ) + hidden construct-delegate ; + +M: hidden render-view* + 2drop ; + +M: hidden render-edit* + >r dup number? [ number>string ] when r> + "hidden" render-input ; + +! String input fields +TUPLE: string min-length max-length ; : ( id -- component ) string ; M: string validate* - [ min>> v-min-length ] keep max>> v-max-length ; + [ v-one-line ] [ + [ min-length>> [ v-min-length ] when* ] + [ max-length>> [ v-max-length ] when* ] + bi + ] bi* ; M: string render-view* drop write ; -: render-input - > dup =id =name =value input/> ; - M: string render-edit* - render-input ; + "text" render-input ; M: string render-error* - render-input render-error ; + "text" render-input render-error ; +! Username fields +TUPLE: username ; + +: ( id -- component ) + username construct-delegate + 2 >>min-length + 20 >>max-length ; + +M: username validate* + delegate validate* v-one-word ; + +! E-mail fields +TUPLE: email ; + +: ( id -- component ) + email construct-delegate + 5 >>min-length + 60 >>max-length ; + +M: email validate* + delegate validate* dup empty? [ v-email ] unless ; + +! Password fields +TUPLE: password ; + +: ( id -- component ) + password construct-delegate + 6 >>min-length + 60 >>max-length ; + +M: password validate* + delegate validate* v-one-word ; + +M: password render-edit* + >r drop f r> "password" render-input ; + +M: password render-error* + render-edit* render-error ; + +! Number fields +TUPLE: number min-value max-value ; + +: ( id -- component ) number ; + +M: number validate* + [ v-number ] [ + [ min-value>> [ v-min-value ] when* ] + [ max-value>> [ v-max-value ] when* ] + bi + ] bi* ; + +M: number render-view* + drop number>string write ; + +M: number render-edit* + >r number>string r> "text" render-input ; + +M: number render-error* + "text" render-input render-error ; + +! Text areas TUPLE: text ; : ( id -- component ) text construct-delegate ; : render-textarea - ; + ; M: text render-edit* render-textarea ; @@ -71,55 +230,11 @@ M: text render-edit* M: text render-error* render-textarea render-error ; -TUPLE: farkup ; +! Simple captchas +TUPLE: captcha ; -: ( id -- component ) farkup construct-delegate ; +: ( id -- component ) + captcha construct-delegate ; -M: farkup render-view* - drop string-lines "\n" join convert-farkup write ; - -TUPLE: number min max ; - -: ( id -- component ) number ; - -M: number validate* - >r v-number r> [ min>> v-min-value ] keep max>> v-max-value ; - -M: number render-view* - drop number>string write ; - -M: number render-edit* - >r number>string r> render-input ; - -M: number render-error* - render-input render-error ; - -: with-components ( tuple components quot -- ) - [ - >r components set - dup make-mirror values set - tuple set - r> call - ] with-scope ; inline - -TUPLE: form view-template edit-template components ; - -: ( id view-template edit-template -- form ) - V{ } clone form construct-boa - swap \ component construct-boa - over set-delegate ; - -: add-field ( form component -- form ) - dup id>> pick components>> set-at ; - -M: form render-view* ( value form -- ) - dup components>> - swap view-template>> - [ resource-path run-template-file ] curry - with-components ; - -M: form render-edit* ( value form -- ) - dup components>> - swap edit-template>> - [ resource-path run-template-file ] curry - with-components ; +M: captcha validate* + drop v-captcha ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor new file mode 100755 index 0000000000..09c8471905 --- /dev/null +++ b/extra/http/server/components/farkup/farkup.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: splitting http.server.components kernel io sequences +farkup ; +IN: http.server.components.farkup + +TUPLE: farkup ; + +: ( id -- component ) + farkup construct-delegate ; + +M: farkup render-view* + drop string-lines "\n" join convert-farkup write ; diff --git a/extra/http/server/components/test/form.fhtml b/extra/http/server/components/test/form.fhtml new file mode 100755 index 0000000000..d3f5a12faa --- /dev/null +++ b/extra/http/server/components/test/form.fhtml @@ -0,0 +1 @@ + diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor old mode 100644 new mode 100755 index 099ded2f7f..4893977f76 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -1,13 +1,69 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: http.server.crud -USING: kernel namespaces db.tuples math.parser -http.server.actions accessors ; +USING: kernel namespaces db.tuples math.parser http.server +http.server.actions http.server.components +http.server.validators accessors fry locals hashtables ; -: by-id ( class -- tuple ) - construct-empty "id" get >>id ; - -: ( class -- action ) +:: ( form ctor -- action ) - { { "id" [ string>number ] } } >>post-params - swap [ by-id delete-tuple f ] curry >>post ; + { { "id" [ v-number ] } } >>get-params + + [ "id" get ctor call select-tuple from-tuple ] >>init + + [ + "text/html" + [ form view-form ] >>body + ] >>display ; + +: ( id next -- response ) + swap number>string "id" associate ; + +:: ( form ctor next -- action ) + + [ f ctor call from-tuple form set-defaults ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple insert-tuple + + "id" value next + ] >>submit ; + +:: ( form ctor next -- action ) + + { { "id" [ v-number ] } } >>get-params + [ "id" get ctor call select-tuple from-tuple ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple update-tuple + + "id" value next + ] >>submit ; + +:: ( ctor next -- action ) + + { { "id" [ v-number ] } } >>post-params + + [ + "id" get ctor call delete-tuple + + next f + ] >>submit ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 511921ce06..4a2315b4fd 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db http.server kernel new-slots accessors -continuations namespaces destructors ; +continuations namespaces destructors combinators.cleave ; IN: http.server.db TUPLE: db-persistence responder db params ; @@ -9,10 +9,8 @@ TUPLE: db-persistence responder db params ; C: db-persistence : connect-db ( db-persistence -- ) - dup db>> swap params>> make-db - dup db set - dup db-open - add-always-destructor ; + [ db>> ] [ params>> ] bi make-db + [ db set ] [ db-open ] [ add-always-destructor ] tri ; M: db-persistence call-responder - dup connect-db responder>> call-responder ; + [ connect-db ] [ responder>> call-responder ] bi ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 0635e1f895..e992a1b6fa 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -2,18 +2,35 @@ USING: http.server tools.test kernel namespaces accessors new-slots io http math sequences assocs ; IN: http.server.tests +[ + + "www.apple.com" >>host + "/xxx/bar" >>path + { { "a" "b" } } >>query + request set + + [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test + [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test + [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test + [ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test + [ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test + [ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test + [ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test + [ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test +] with-scope + TUPLE: mock-responder path ; C: mock-responder M: mock-responder call-responder - 2nip + nip path>> on "text/plain" ; : check-dispatch ( tag path -- ? ) over off - swap default-host get call-responder + main-responder get call-responder write-response get ; [ @@ -24,14 +41,14 @@ M: mock-responder call-responder "123" "123" add-responder "default" >>default "baz" add-responder - default-host set + main-responder set [ "foo" ] [ - "foo" default-host get find-responder path>> nip + "foo" main-responder get find-responder path>> nip ] unit-test [ "bar" ] [ - "bar" default-host get find-responder path>> nip + "bar" main-responder get find-responder path>> nip ] unit-test [ t ] [ "foo" "foo" check-dispatch ] unit-test @@ -46,7 +63,8 @@ M: mock-responder call-responder [ t ] [ "baz" >>path - "baz" default-host get call-responder + request set + "baz" main-responder get call-responder dup code>> 300 399 between? >r header>> "location" swap at "baz/" tail? r> and ] unit-test @@ -55,7 +73,7 @@ M: mock-responder call-responder [ "default" >>default - default-host set + main-responder set - [ "/default" ] [ "/default" default-host get find-responder drop ] unit-test + [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test ] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 133783114d..37f21278df 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -4,10 +4,15 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib vocabs.loader debugger html continuations random combinators -destructors io.encodings.latin1 ; +destructors io.encodings.latin1 fry combinators.cleave ; IN: http.server -GENERIC: call-responder ( request path responder -- response ) +GENERIC: call-responder ( path responder -- response ) + +: ( content-type -- response ) + + 200 >>code + swap set-content-type ; TUPLE: trivial-responder response ; @@ -18,16 +23,16 @@ M: trivial-responder call-responder nip response>> call ; : trivial-response-body ( code message -- ) -

swap number>string write bl write

+

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

; : ( code message -- response ) - - 2over [ trivial-response-body ] 2curry >>body - "text/html" set-content-type - swap >>message - swap >>code ; + 2dup '[ , , trivial-response-body ] + "text/html" + swap >>body + swap >>message + swap >>code ; : <400> ( -- response ) 400 "Bad request" ; @@ -37,41 +42,58 @@ M: trivial-responder call-responder nip response>> call ; SYMBOL: 404-responder -[ drop <404> ] 404-responder set-global +[ <404> ] 404-responder set-global -: modify-for-redirect ( request to -- url ) +: url-redirect ( to query -- url ) + #! Different host. + dup assoc-empty? [ + drop + ] [ + assoc>query "?" swap 3append + ] if ; + +: absolute-redirect ( to query -- url ) + #! Same host. + request get clone + swap [ >>query ] when* + swap >>path + request-url ; + +: replace-last-component ( path with -- path' ) + >r "/" last-split1 drop "/" r> 3append ; + +: relative-redirect ( to query -- url ) + request get clone + swap [ >>query ] when* + swap [ '[ , replace-last-component ] change-path ] when* + request-url ; + +: derive-url ( to query -- url ) { - { [ dup "http://" head? ] [ nip ] } - { [ dup "/" head? ] [ >>path request-url ] } - { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] } + { [ over "http://" head? ] [ url-redirect ] } + { [ over "/" head? ] [ absolute-redirect ] } + { [ t ] [ relative-redirect ] } } cond ; -: ( request to code message -- response ) - - -rot modify-for-redirect - "location" set-header ; +: ( to query code message -- response ) + -rot derive-url "location" set-header ; \ DEBUG add-input-logging -: ( request to -- response ) +: ( to query -- response ) 301 "Moved Permanently" ; -: ( request to -- response ) +: ( to query -- response ) 307 "Temporary Redirect" ; -: ( content-type -- response ) - - 200 >>code - swap set-content-type ; - TUPLE: dispatcher default responders ; : ( -- dispatcher ) - 404-responder H{ } clone dispatcher construct-boa ; + 404-responder get H{ } clone dispatcher construct-boa ; : set-main ( dispatcher name -- dispatcher ) - [ ] curry - >>default ; + '[ , f ] + >>default ; : split-path ( path -- rest first ) [ CHAR: / = ] left-trim "/" split1 swap ; @@ -80,18 +102,18 @@ TUPLE: dispatcher default responders ; over split-path pick responders>> at* [ >r >r 2drop r> r> ] [ 2drop default>> ] if ; -: redirect-with-/ ( request -- response ) - dup path>> "/" append ; +: redirect-with-/ ( -- response ) + request get path>> "/" append f ; -M: dispatcher call-responder +M: dispatcher call-responder ( path dispatcher -- response ) over [ - 3dup find-responder call-responder [ - >r 3drop r> + 2dup find-responder call-responder [ + 2nip ] [ default>> [ call-responder ] [ - 3drop f + drop f ] if* ] if* ] [ @@ -107,21 +129,18 @@ M: dispatcher call-responder : ( class -- dispatcher ) swap construct-delegate ; inline -SYMBOL: virtual-hosts -SYMBOL: default-host +SYMBOL: main-responder -virtual-hosts global [ drop H{ } clone ] cache drop -default-host global [ drop 404-responder get-global ] cache drop - -: find-virtual-host ( host -- responder ) - virtual-hosts get at [ default-host get ] unless* ; +main-responder global +[ drop 404-responder get-global ] cache +drop SYMBOL: development-mode : <500> ( error -- response ) 500 "Internal server error" - swap [ - "Internal server error" [ + swap '[ + , "Internal server error" [ development-mode get [ [ print-error nl :c ] with-html-stream ] [ @@ -129,27 +148,40 @@ SYMBOL: development-mode trivial-response-body ] if ] simple-page - ] curry >>body ; + ] >>body ; -: do-response ( request response -- ) +: do-response ( response -- ) dup write-response - swap method>> "HEAD" = + request get method>> "HEAD" = [ drop ] [ write-response-body ] if ; -: do-request ( request -- response ) - [ - dup dup path>> over host>> - find-virtual-host call-responder - [ <404> ] unless* - ] [ dup \ do-request log-error <500> ] recover ; - -: default-timeout 1 minutes stdio get set-timeout ; - LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; +SYMBOL: exit-continuation + +: exit-with exit-continuation get continue-with ; + +: do-request ( request -- response ) + '[ + exit-continuation set , + [ + [ log-request ] + [ request set ] + [ path>> main-responder get call-responder ] tri + [ <404> ] unless* + ] [ + [ \ do-request log-error ] + [ <500> ] + bi + ] recover + ] callcc1 + exit-continuation off ; + +: default-timeout 1 minutes stdio get set-timeout ; + : ?refresh-all ( -- ) development-mode get-global [ global [ refresh-all ] bind ] when ; @@ -159,8 +191,8 @@ LOG: httpd-hit NOTICE default-timeout ?refresh-all read-request - dup log-request - do-request do-response + do-request + do-response ] with-destructors ; : httpd ( port -- ) @@ -171,6 +203,10 @@ LOG: httpd-hit NOTICE MAIN: httpd-main +! Utility : generate-key ( assoc -- str ) - 4 big-random >hex dup pick key? - [ drop generate-key ] [ nip ] if ; + >r random-256 >hex r> + 2dup key? [ nip generate-key ] [ drop ] if ; + +: set-at-unique ( value assoc -- key ) + dup generate-key [ swap set-at ] keep ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index d771737c73..5c2d3a57cd 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -8,9 +8,9 @@ TUPLE: foo ; C: foo -M: foo init-session drop 0 "x" sset ; +M: foo init-session* drop 0 "x" sset ; -"1234" f [ +f [ [ ] [ 3 "x" sset ] unit-test [ 9 ] [ "x" sget sq ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index d7fed6bb64..1d90a32faf 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -2,16 +2,16 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs calendar kernel math.parser namespaces random boxes alarms new-slots accessors http http.server -quotations hashtables sequences ; +quotations hashtables sequences fry combinators.cleave ; IN: http.server.sessions ! ! ! ! ! ! ! WARNING: this session manager is vulnerable to XSRF attacks ! ! ! ! ! ! -GENERIC: init-session ( responder -- ) +GENERIC: init-session* ( responder -- ) -M: dispatcher init-session drop ; +M: dispatcher init-session* drop ; TUPLE: session-manager responder sessions ; @@ -19,10 +19,10 @@ TUPLE: session-manager responder sessions ; >r H{ } clone session-manager construct-boa r> construct-delegate ; inline -TUPLE: session id manager namespace alarm ; +TUPLE: session manager id namespace alarm ; -: ( id manager -- session ) - H{ } clone \ session construct-boa ; +: ( manager -- session ) + f H{ } clone \ session construct-boa ; : timeout ( -- dt ) 20 minutes ; @@ -30,13 +30,15 @@ TUPLE: session id manager namespace alarm ; alarm>> [ cancel-alarm ] if-box? ; : delete-session ( session -- ) - dup cancel-timeout - dup manager>> sessions>> delete-at ; + [ cancel-timeout ] + [ dup manager>> sessions>> delete-at ] + bi ; -: touch-session ( session -- ) - dup cancel-timeout - dup [ delete-session ] curry timeout later - swap session-alarm >box ; +: touch-session ( session -- session ) + [ cancel-timeout ] + [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ] + [ ] + tri ; : session ( -- assoc ) \ session get namespace>> ; @@ -46,20 +48,20 @@ TUPLE: session id manager namespace alarm ; : schange ( key quot -- ) session swap change-at ; inline +: init-session ( session -- session ) + dup dup \ session [ + manager>> responder>> init-session* + ] with-variable ; + : new-session ( responder -- id ) - [ sessions>> generate-key dup ] keep - [ dup touch-session ] keep - [ swap \ session [ responder>> init-session ] with-variable ] 2keep - >r over r> sessions>> set-at ; + [ init-session touch-session ] + [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ] + bi id>> ; -: get-session ( id responder -- session ) - sessions>> tuck at* [ - nip dup touch-session - ] [ - 2drop f - ] if ; +: get-session ( id responder -- session/f ) + sessions>> at* [ touch-session ] when ; -: call-responder/session ( request path responder session -- response ) +: call-responder/session ( path responder session -- response ) \ session set responder>> call-responder ; : sessions ( -- manager/f ) @@ -71,6 +73,14 @@ M: object session-link* 2drop url-encode ; : session-link ( url query -- string ) sessions session-link* ; +TUPLE: null-sessions ; + +: + null-sessions ; + +M: null-sessions call-responder ( path responder -- response ) + dup call-responder/session ; + TUPLE: url-sessions ; : ( responder -- responder' ) @@ -78,18 +88,21 @@ TUPLE: url-sessions ; : sess-id "factorsessid" ; -M: url-sessions call-responder ( request path responder -- response ) - pick sess-id query-param over get-session [ +: current-session ( responder request -- session ) + sess-id query-param swap get-session ; + +M: url-sessions call-responder ( path responder -- response ) + dup request get current-session [ call-responder/session ] [ - new-session nip sess-id set-query-param - dup request-url + nip + f swap new-session sess-id associate ] if* ; M: url-sessions session-link* drop + url-encode \ session get id>> sess-id associate union assoc>query - >r url-encode r> dup assoc-empty? [ drop ] [ "?" swap 3append ] if ; TUPLE: cookie-sessions ; @@ -97,15 +110,15 @@ TUPLE: cookie-sessions ; : ( responder -- responder' ) cookie-sessions ; -: get-session-cookie ( request responder -- cookie ) - >r sess-id get-cookie dup - [ value>> r> get-session ] [ r> 2drop f ] if ; +: get-session-cookie ( responder -- cookie ) + request get sess-id get-cookie + [ value>> swap get-session ] [ drop f ] if* ; : ( id -- cookie ) sess-id ; -M: cookie-sessions call-responder ( request path responder -- response ) - 3dup nip get-session-cookie [ +M: cookie-sessions call-responder ( path responder -- response ) + dup get-session-cookie [ call-responder/session ] [ dup new-session diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 93eb51ce4e..6c365ad87b 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -3,7 +3,8 @@ USING: calendar html io io.files kernel math math.parser http http.server namespaces parser sequences strings assocs hashtables debugger http.mime sorting html.elements logging -calendar.format new-slots accessors io.encodings.binary ; +calendar.format new-slots accessors io.encodings.binary +combinators.cleave fry ; IN: http.server.static SYMBOL: responder @@ -31,21 +32,23 @@ TUPLE: file-responder root hook special ; : ( root -- responder ) [ - over file-length "content-length" set-header - over file-http-date "last-modified" set-header - swap [ binary stdio get stream-copy ] curry >>body + swap + [ file-length "content-length" set-header ] + [ file-http-date "last-modified" set-header ] + [ '[ , binary stdio get stream-copy ] >>body ] + tri ] ; : serve-static ( filename mime-type -- response ) over last-modified-matches? - [ 2drop <304> ] [ responder get hook>> call ] if ; + [ 2drop <304> ] [ file-responder get hook>> call ] if ; : serving-path ( filename -- filename ) - "" or responder get root>> swap path+ ; + "" or file-responder get root>> swap path+ ; : serve-file ( filename -- response ) dup mime-type - dup responder get special>> at + dup file-responder get special>> at [ call ] [ serve-static ] ?if ; \ serve-file NOTICE add-input-logging @@ -56,21 +59,22 @@ TUPLE: file-responder root hook special ; : directory. ( path -- ) dup file-name [ -

dup file-name write

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

file-name write

] + [ +
    + directory sort-keys + [
  • file.
    • ] assoc-each +
+ ] bi ] simple-html-document ; : list-directory ( directory -- response ) "text/html" - swap [ directory. ] curry >>body ; + swap '[ , directory. ] >>body ; : find-index ( filename -- path ) - { "index.html" "index.fhtml" } - [ dupd path+ exists? ] find nip - dup [ path+ ] [ nip ] if ; + { "index.html" "index.fhtml" } [ path+ ] with map + [ exists? ] find nip ; : serve-directory ( filename -- response ) dup "/" tail? [ @@ -87,15 +91,14 @@ TUPLE: file-responder root hook special ; drop <404> ] if ; -M: file-responder call-responder ( request path responder -- response ) - over [ - ".." pick subseq? [ - 3drop <400> +M: file-responder call-responder ( path responder -- response ) + file-responder set + dup [ + ".." over subseq? [ + drop <400> ] [ - responder set - swap request set serve-object ] if ] [ - 2drop redirect-with-/ + drop redirect-with-/ ] if ; diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index e655bf9001..9774e4c1f2 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -4,12 +4,12 @@ parser ; IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) - "extra/http/server/templating/fhtml/test/" swap append + "resource:extra/http/server/templating/fhtml/test/" + swap append [ - ".fhtml" append resource-path - [ run-template-file ] with-string-writer + ".fhtml" append [ run-template ] with-string-writer ] keep - ".html" append resource-path utf8 file-contents = ; + ".html" append ?resource-path utf8 file-contents = ; [ t ] [ "example" test-template ] unit-test [ t ] [ "bug" test-template ] unit-test diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 3dcd23b99f..8567524217 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -2,10 +2,10 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel parser namespaces io -io.files io.streams.string html html.elements -source-files debugger combinators math quotations generic -strings splitting accessors http.server.static http.server -assocs io.encodings.utf8 ; +io.files io.streams.string html html.elements source-files +debugger combinators math quotations generic strings splitting +accessors http.server.static http.server assocs +io.encodings.utf8 fry ; IN: http.server.templating.fhtml @@ -75,9 +75,9 @@ DEFER: <% delimiter : html-error. ( error -- ) 
 error.
; -: run-template-file ( filename -- ) - [ - [ +: run-template ( filename -- ) + '[ + , [ "quiet" on parser-notes off templating-vocab use+ @@ -86,21 +86,18 @@ DEFER: <% delimiter ?resource-path utf8 file-contents [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs - ] curry assert-depth ; - -: run-relative-template-file ( filename -- ) - file get source-file-path parent-directory - swap path+ run-template-file ; + ] assert-depth ; : template-convert ( infile outfile -- ) - utf8 [ run-template-file ] with-file-writer ; + utf8 [ run-template ] with-file-writer ; + +! responder integration +: serve-template ( name -- response ) + "text/html" + swap '[ , run-template ] >>body ; ! file responder integration -: serve-fhtml ( filename -- response ) - "text/html" - swap [ run-template-file ] curry >>body ; - : enable-fhtml ( responder -- responder ) - [ serve-fhtml ] + [ serve-template ] "application/x-factor-server-page" pick special>> set-at ; diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor old mode 100644 new mode 100755 index ff68dcfc64..3ef2b6c863 --- a/extra/http/server/validators/validators-tests.factor +++ b/extra/http/server/validators/validators-tests.factor @@ -1,4 +1,22 @@ IN: http.server.validators.tests -USING: kernel sequences tools.test http.server.validators ; +USING: kernel sequences tools.test http.server.validators +accessors ; -[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test +[ "foo" v-number ] [ validation-error? ] must-fail-with + +[ "slava@factorcode.org" ] [ + "slava@factorcode.org" v-email +] unit-test + +[ "slava+foo@factorcode.org" ] [ + "slava+foo@factorcode.org" v-email +] unit-test + +[ "slava@factorcode.o" v-email ] +[ reason>> "invalid e-mail" = ] must-fail-with + +[ "sla@@factorcode.o" v-email ] +[ reason>> "invalid e-mail" = ] must-fail-with + +[ "slava@factorcodeorg" v-email ] +[ reason>> "invalid e-mail" = ] must-fail-with diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor old mode 100644 new mode 100755 index 03beb8c3ff..7eb5163d33 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences math namespaces -math.parser assocs new-slots ; +math.parser assocs new-slots regexp fry unicode.categories +combinators.cleave sequences ; IN: http.server.validators TUPLE: validation-error value reason ; @@ -9,17 +10,6 @@ TUPLE: validation-error value reason ; : validation-error ( value reason -- * ) \ validation-error construct-boa throw ; -: with-validator ( string quot -- result error? ) - [ f ] compose curry - [ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline - -: validate-param ( name validator assoc -- error? ) - swap pick - >r >r at r> with-validator swap r> set ; - -: validate-params ( validators assoc -- error? ) - [ validate-param ] curry { } assoc>map [ ] contains? ; - : v-default ( str def -- str ) over empty? spin ? ; @@ -47,7 +37,7 @@ TUPLE: validation-error value reason ; "must be a number" validation-error ] ?if ; -: v-min-value ( str n -- str ) +: v-min-value ( x n -- x ) 2dup < [ [ "must be at least " % # ] "" make validation-error @@ -55,10 +45,31 @@ TUPLE: validation-error value reason ; drop ] if ; -: v-max-value ( str n -- str ) +: v-max-value ( x n -- x ) 2dup > [ [ "must be no more than " % # ] "" make validation-error ] [ drop ] if ; + +: v-regexp ( str what regexp -- str ) + >r over r> matches? + [ drop ] [ "invalid " swap append validation-error ] if ; + +: v-email ( str -- str ) + #! From http://www.regular-expressions.info/email.html + "e-mail" + R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i + v-regexp ; + +: v-captcha ( str -- str ) + dup empty? [ "must remain blank" validation-error ] unless ; + +: v-one-line ( str -- str ) + dup "\r\n" seq-intersect empty? + [ "must be a single line" validation-error ] unless ; + +: v-one-word ( str -- str ) + dup [ alpha? ] all? + [ "must be a single word" validation-error ] unless ; diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor index 47e619cc00..a13e412afe 100755 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -1,5 +1,6 @@ -USING: xmode.tokens xmode.marker xmode.catalog kernel html html.elements io - io.files sequences words io.encodings.utf8 ; +USING: xmode.tokens xmode.marker xmode.catalog kernel html +html.elements io io.files sequences words io.encodings.utf8 +namespaces ; IN: xmode.code2html : htmlize-tokens ( tokens -- ) @@ -40,5 +41,9 @@ IN: xmode.code2html ; : htmlize-file ( path -- ) - dup utf8 over ".html" append utf8 - [ htmlize-stream ] with-stream ; + dup utf8 [ + stdio get + over ".html" append utf8 [ + htmlize-stream + ] with-file-writer + ] with-file-reader ; diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor index d14ffd93b3..379f6d6c94 100755 --- a/extra/xmode/code2html/responder/responder.factor +++ b/extra/xmode/code2html/responder/responder.factor @@ -1,15 +1,21 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files namespaces http.server http.server.static http -xmode.code2html kernel html sequences accessors ; +USING: io.files io.encodings.utf8 namespaces http.server +http.server.static http xmode.code2html kernel html sequences +accessors fry combinators.cleave ; IN: xmode.code2html.responder : ( root -- responder ) [ drop - "text/html" - over file-http-date "last-modified" set-header - swap [ - dup file-name swap htmlize-stream - ] curry >>body + "text/html" swap + [ file-http-date "last-modified" set-header ] + [ + '[ + , + dup file-name swap utf8 + + [ htmlize-stream ] with-html-stream + ] >>body + ] bi ] ; From ae3963a07217ac7c2ccba518d4c213e93294258b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Mar 2008 03:39:50 -0500 Subject: [PATCH 12/14] Fix builder for word renaming --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100644 new mode 100755 index 68f525ec6c..da96e51dd4 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -164,7 +164,7 @@ SYMBOL: builder-recipients builder-recipients get >>to subject >>subject "./report" file>string >>body - send ; + send-email ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 2f505f85d11772f2d3691da9a2b7923c5af808ef Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 12 Mar 2008 13:35:48 +1100 Subject: [PATCH 13/14] fixed gap-buffer and cursortree --- .../cursortree/cursortree-tests.factor | 7 ++-- extra/gap-buffer/cursortree/cursortree.factor | 19 ++++++----- extra/gap-buffer/gap-buffer.factor | 34 +++++++++++++++---- 3 files changed, 44 insertions(+), 16 deletions(-) diff --git a/extra/gap-buffer/cursortree/cursortree-tests.factor b/extra/gap-buffer/cursortree/cursortree-tests.factor index 36b5efd7fa..2b3ff69c97 100644 --- a/extra/gap-buffer/cursortree/cursortree-tests.factor +++ b/extra/gap-buffer/cursortree/cursortree-tests.factor @@ -1,4 +1,6 @@ -USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ; +USING: assocs kernel gap-buffer.cursortree tools.test sequences trees +arrays strings ; +IN: gap-buffer.cursortree.tests [ t ] [ "this is a test string" 0 at-beginning? ] unit-test [ t ] [ "this is a test string" dup length at-end? ] unit-test @@ -6,7 +8,8 @@ USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ; [ CHAR: i ] [ "this is a test string" 3 element< ] unit-test [ CHAR: s ] [ "this is a test string" 3 element> ] unit-test [ t ] [ "this is a test string" 3 CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test -[ t ] [ "this is a test string" 3 8 over set-cursor-pos dup 1array swap cursor-tree cursortree-cursors tree-values sequence= ] unit-test +[ 0 ] [ "this is a test string" dup dup 3 remove-cursor cursors length ] unit-test +[ t ] [ "this is a test string" 3 8 over set-cursor-pos dup 1array swap cursor-tree cursors sequence= ] unit-test [ "this is no longer a test string" ] [ "this is a test string" 8 "no longer " over insert cursor-tree >string ] unit-test [ "refactor" ] [ "factor" 0 CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test [ "refactor" ] [ "factor" 0 CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test diff --git a/extra/gap-buffer/cursortree/cursortree.factor b/extra/gap-buffer/cursortree/cursortree.factor index e056cc8dee..fb2abf1c3d 100644 --- a/extra/gap-buffer/cursortree/cursortree.factor +++ b/extra/gap-buffer/cursortree/cursortree.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Alex Chapman All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel gap-buffer generic trees trees.avl math sequences quotations ; +USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math +sequences quotations ; IN: gap-buffer.cursortree TUPLE: cursortree cursors ; @@ -18,13 +19,12 @@ TUPLE: cursor i tree ; TUPLE: left-cursor ; TUPLE: right-cursor ; -: cursor-index ( cursor -- i ) cursor-i ; inline +: cursor-index ( cursor -- i ) cursor-i ; -: add-cursor ( cursortree cursor -- ) dup cursor-index rot avl-insert ; +: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ; : remove-cursor ( cursortree cursor -- ) - cursor-index swap delete-at ; - ! dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ; + tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ; : set-cursor-index ( index cursor -- ) dup cursor-tree over remove-cursor tuck set-cursor-i @@ -49,14 +49,17 @@ M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] ke : ( cursortree pos -- right-cursor ) right-cursor construct-empty make-cursor ; +: cursors ( cursortree -- seq ) + cursortree-cursors values concat ; + : cursor-positions ( cursortree -- seq ) - cursortree-cursors tree-values [ cursor-pos ] map ; + cursors [ cursor-pos ] map ; M: cursortree move-gap ( n cursortree -- ) #! Get the position of each cursor before the move, then re-set the #! position afterwards. This will update any changed cursor indices. dup cursor-positions >r tuck cursortree-gb move-gap - cursortree-cursors tree-values r> swap [ set-cursor-pos ] 2each ; + cursors r> swap [ set-cursor-pos ] 2each ; : element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ; : element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ; @@ -81,7 +84,7 @@ M: right-cursor fix-cursor ( cursortree cursor -- ) >r gb-gap-end r> set-cursor-index ; : fix-cursors ( old-gap-end cursortree -- ) - tuck cursortree-cursors tree-get-all [ fix-cursor ] curry* each ; + tuck cursortree-cursors at [ fix-cursor ] with each ; M: cursortree delete* ( pos cursortree -- ) tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ; diff --git a/extra/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor index 99051ea678..3d78204d3f 100644 --- a/extra/gap-buffer/gap-buffer.factor +++ b/extra/gap-buffer/gap-buffer.factor @@ -44,15 +44,36 @@ M: gb like ( seq gb -- seq ) drop ; M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ; +: valid-position? ( pos gb -- ? ) + #! one element past the end of the buffer is a valid position when we're inserting + length -1 swap between? ; + +: valid-index? ( i gb -- ? ) + buffer-length -1 swap between? ; + +TUPLE: position-out-of-bounds position gap-buffer ; +C: position-out-of-bounds + : position>index ( pos gb -- i ) - 2dup gb-gap-start >= [ - gap-length + - ] [ drop ] if ; + 2dup valid-position? [ + 2dup gb-gap-start >= [ + gap-length + + ] [ drop ] if + ] [ + throw + ] if ; + +TUPLE: index-out-of-bounds index gap-buffer ; +C: index-out-of-bounds : index>position ( i gb -- pos ) - 2dup gb-gap-end >= [ - gap-length - - ] [ drop ] if ; + 2dup valid-index? [ + 2dup gb-gap-end >= [ + gap-length - + ] [ drop ] if + ] [ + throw + ] if ; M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ; @@ -159,6 +180,7 @@ INSTANCE: gb virtual-sequence : fix-gap ( n gb -- ) 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ; +! moving the gap to position 5 means that the element in position 5 will be immediately after the gap GENERIC: move-gap ( n gb -- ) M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ; From 99d2b29b7e34cb3d3d73b4a64f8b63ed12790a03 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 12 Mar 2008 13:54:01 +1100 Subject: [PATCH 14/14] renamed hooks to triggers --- extra/hooks/hooks-tests.factor | 14 -------------- extra/hooks/hooks.factor | 28 ---------------------------- extra/triggers/authors.txt | 1 + extra/triggers/summary.txt | 1 + extra/triggers/triggers-tests.factor | 14 ++++++++++++++ extra/triggers/triggers.factor | 28 ++++++++++++++++++++++++++++ 6 files changed, 44 insertions(+), 42 deletions(-) delete mode 100644 extra/hooks/hooks-tests.factor delete mode 100644 extra/hooks/hooks.factor create mode 100644 extra/triggers/authors.txt create mode 100644 extra/triggers/summary.txt create mode 100644 extra/triggers/triggers-tests.factor create mode 100644 extra/triggers/triggers.factor diff --git a/extra/hooks/hooks-tests.factor b/extra/hooks/hooks-tests.factor deleted file mode 100644 index 683109f795..0000000000 --- a/extra/hooks/hooks-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: hooks kernel tools.test ; -IN: hooks.tests - -SYMBOL: test-hook -test-hook reset-hook -: add-test-hook test-hook add-hook ; -[ ] [ test-hook call-hook ] unit-test -[ "op called" ] [ "op" [ "op called" ] add-test-hook test-hook call-hook ] unit-test -[ "first called" "second called" ] [ - test-hook reset-hook - "second op" [ "second called" ] add-test-hook - "first op" [ "first called" ] add-test-hook - test-hook call-hook -] unit-test diff --git a/extra/hooks/hooks.factor b/extra/hooks/hooks.factor deleted file mode 100644 index 65e310f268..0000000000 --- a/extra/hooks/hooks.factor +++ /dev/null @@ -1,28 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: assocs digraphs kernel namespaces sequences ; -IN: hooks - -: hooks ( -- hooks ) - \ hooks global [ drop H{ } clone ] cache ; - -: hook-graph ( hook -- graph ) - hooks [ drop ] cache ; - -: reset-hook ( hook -- ) - swap hooks set-at ; - -: add-hook ( key quot hook -- ) - #! hook should be a symbol. Note that symbols with the same name but - #! different vocab are not equal - hook-graph add-vertex ; - -: before ( key1 key2 hook -- ) - hook-graph add-edge ; - -: after ( key1 key2 hook -- ) - swapd before ; - -: call-hook ( hook -- ) - hook-graph topological-sorted-values [ call ] each ; - diff --git a/extra/triggers/authors.txt b/extra/triggers/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/triggers/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/triggers/summary.txt b/extra/triggers/summary.txt new file mode 100644 index 0000000000..34353dc799 --- /dev/null +++ b/extra/triggers/summary.txt @@ -0,0 +1 @@ +triggers allow you to register code to be 'triggered' diff --git a/extra/triggers/triggers-tests.factor b/extra/triggers/triggers-tests.factor new file mode 100644 index 0000000000..744a4b13a7 --- /dev/null +++ b/extra/triggers/triggers-tests.factor @@ -0,0 +1,14 @@ +USING: triggers kernel tools.test ; +IN: triggers.tests + +SYMBOL: test-trigger +test-trigger reset-trigger +: add-test-trigger test-trigger add-trigger ; +[ ] [ test-trigger call-trigger ] unit-test +[ "op called" ] [ "op" [ "op called" ] add-test-trigger test-trigger call-trigger ] unit-test +[ "first called" "second called" ] [ + test-trigger reset-trigger + "second op" [ "second called" ] add-test-trigger + "first op" [ "first called" ] add-test-trigger + test-trigger call-trigger +] unit-test diff --git a/extra/triggers/triggers.factor b/extra/triggers/triggers.factor new file mode 100644 index 0000000000..ffdfe373cd --- /dev/null +++ b/extra/triggers/triggers.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: assocs digraphs kernel namespaces sequences ; +IN: triggers + +: triggers ( -- triggers ) + \ triggers global [ drop H{ } clone ] cache ; + +: trigger-graph ( trigger -- graph ) + triggers [ drop ] cache ; + +: reset-trigger ( trigger -- ) + swap triggers set-at ; + +: add-trigger ( key quot trigger -- ) + #! trigger should be a symbol. Note that symbols with the same name but + #! different vocab are not equal + trigger-graph add-vertex ; + +: before ( key1 key2 trigger -- ) + trigger-graph add-edge ; + +: after ( key1 key2 trigger -- ) + swapd before ; + +: call-trigger ( trigger -- ) + trigger-graph topological-sorted-values [ call ] each ; +