From 9b3964c5d68b9201847c74bd13dac468595e6863 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 00:30:51 -0500 Subject: [PATCH 01/71] Add disable images option --- extra/farkup/farkup.factor | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index d5110de02d..321648136a 100755 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -7,6 +7,7 @@ sequences.deep unicode.categories ; IN: farkup SYMBOL: relative-link-prefix +SYMBOL: disable-images? SYMBOL: link-no-follow? r , r> + " href=\"" , >r , r> "\"" , link-no-follow? get [ " nofollow=\"true\"" , ] when - "\">" , , "" , + ">" , , "" , ] { } make ; : make-image-link ( href alt -- seq ) - escape-link - [ - "\""" , ] - { } make ; + disable-images? get [ + 2drop "Images are not allowed" + ] [ + escape-link + [ + "\""" , + ] { } make + ] if ; MEMO: image-link ( -- parser ) [ From 51bfaf249b59905147977806b952b40c6644fb94 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 00:31:00 -0500 Subject: [PATCH 02/71] Unit test fix --- extra/furnace/sessions/sessions-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor index e959cae76a..a97ba091c0 100755 --- a/extra/furnace/sessions/sessions-tests.factor +++ b/extra/furnace/sessions/sessions-tests.factor @@ -65,7 +65,7 @@ M: foo call-responder* [ [ ] [ - empty-session + empty-session 123 >>id session set ] unit-test From 2c3121cf472cb4412e61145ebb4d2e75d49a45d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 00:31:10 -0500 Subject: [PATCH 03/71] Add support for some attributes to farkup tag --- extra/html/components/components.factor | 14 ++++++++++++-- extra/html/templates/chloe/chloe.factor | 2 +- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index 42d89811c1..6e1a25f5f5 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -200,10 +200,20 @@ M: code render* [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ; ! Farkup component -SINGLETON: farkup +TUPLE: farkup no-follow disable-images ; + +: string>boolean ( string -- boolean ) + { + { "true" [ t ] } + { "false" [ f ] } + } case ; M: farkup render* - 2drop string-lines "\n" join convert-farkup write ; + [ + [ no-follow>> [ string>boolean link-no-follow? set ] when* ] + [ disable-images>> [ string>boolean disable-images? set ] when* ] bi + drop string-lines "\n" join convert-farkup write + ] with-scope ; ! Inspector component SINGLETON: inspector diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 08d6b873fc..936c06ae7e 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -98,12 +98,12 @@ CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; CHLOE-SINGLETON: label CHLOE-SINGLETON: link -CHLOE-SINGLETON: farkup CHLOE-SINGLETON: inspector CHLOE-SINGLETON: comparison CHLOE-SINGLETON: html CHLOE-SINGLETON: hidden +CHLOE-TUPLE: farkup CHLOE-TUPLE: field CHLOE-TUPLE: textarea CHLOE-TUPLE: password From f0a37253f2d123e5ea313be7403641a50cbba4b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 00:31:24 -0500 Subject: [PATCH 04/71] Disable comments, make links nofollow in blog posts --- extra/webapps/blogs/view-post.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml index 55bdd2e806..d8d4df10b2 100644 --- a/extra/webapps/blogs/view-post.xml +++ b/extra/webapps/blogs/view-post.xml @@ -37,7 +37,7 @@

- +

Delete Comment From 2d35ea233ff5860245dc1df0da1f006dcc737cb0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 00:44:23 -0500 Subject: [PATCH 05/71] Fix missing rest parameters --- extra/webapps/blogs/blogs.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 38bf065e56..d0c651c71f 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -116,6 +116,7 @@ M: comment entity-url : ( -- action ) + "author" >>rest [ validate-author ] >>init [ "Recent Posts by " "author" value append ] >>title [ list-posts ] >>entries @@ -123,6 +124,7 @@ M: comment entity-url : ( -- action ) + "id" >>rest [ validate-integer-id "id" value post "post" set-value ] >>init [ "post" value feed-entry-title ] >>title [ "post" value entity-url ] >>url From 23f957850535953071464461b40ad5c7ecfb0b98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 02:45:04 -0500 Subject: [PATCH 06/71] Remove micro-pessimization --- extra/io/ports/ports.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index b761ecaf5b..f54cd2e9b3 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -98,11 +98,9 @@ TUPLE: output-port < buffered-port ; : ( handle -- output-port ) output-port ; -: can-write? ( len buffer -- ? ) - [ buffer-fill + ] keep buffer-capacity <= ; - : wait-to-write ( len port -- ) - tuck buffer>> can-write? [ drop ] [ stream-flush ] if ; + tuck buffer>> buffer-capacity <= + [ drop ] [ stream-flush ] if ; M: output-port stream-write1 dup check-disposed From faa96f887bbc37492b7a1df3c3ad815c91ac3c71 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 02:45:26 -0500 Subject: [PATCH 07/71] Log rotation --- extra/http/server/server.factor | 5 ++++- extra/logging/logging.factor | 8 +++----- extra/webapps/factor-website/factor-website.factor | 4 ++++ 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 4ad44554f5..095b52171c 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -13,7 +13,7 @@ io.encodings.ascii io.encodings.binary io.streams.limited io.timeouts -fry logging calendar urls +fry logging logging.insomniac calendar urls http http.server.responses html.elements @@ -140,4 +140,7 @@ LOG: httpd-hit NOTICE : httpd-main ( -- ) 8888 httpd ; +: httpd-insomniac ( -- ) + "http.server" { httpd-hit } schedule-insomniac ; + MAIN: httpd-main diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index f46fcf6c53..5168e7fcd2 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -42,11 +42,9 @@ SYMBOL: log-service message ( obj -- inputs>message ) - dup one-string-array? [ first ] [ + dup array? [ dup length 1 = [ first ] when ] when + dup string? [ [ string-limit off 1 line-limit set @@ -54,7 +52,7 @@ PREDICATE: one-string-array < array 0 margin set unparse ] with-scope - ] if ; + ] unless ; PRIVATE> diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index fa598c0948..04fc0487b8 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -3,6 +3,7 @@ USING: accessors kernel sequences assocs io.files io.sockets io.server namespaces db db.tuples db.sqlite smtp +logging.insomniac http.server http.server.dispatchers furnace.alloy @@ -61,10 +62,13 @@ TUPLE: factor-website < dispatcher ; : init-factor-website ( -- ) "factorcode.org" 25 smtp-server set-global "todo@factorcode.org" lost-password-from set-global + "website@factorcode.org" insomniac-sender set-global + "slava@factorcode.org" insomniac-recipients set-global init-factor-db main-responder set-global ; : start-factor-website ( -- ) test-db start-expiring test-db start-update-task + httpd-insomniac 8812 httpd ; From 4e4731ec67fdbdcdce5f557d434e0de634d99a97 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 02:45:34 -0500 Subject: [PATCH 08/71] Fix rollback --- extra/webapps/wiki/revisions.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 97a051cd96..0e1af75a8f 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -16,7 +16,7 @@ - Rollback + Rollback From 9516d781542f44754e38c6b411ddac10b02bd1c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 04:00:40 -0500 Subject: [PATCH 09/71] Fix bootstrap --- extra/io/ports/ports-docs.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/io/ports/ports-docs.factor b/extra/io/ports/ports-docs.factor index 7420cac115..47485193cf 100755 --- a/extra/io/ports/ports-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -64,7 +64,3 @@ HELP: (wait-to-read) HELP: wait-to-read { $values { "port" input-port } { "eof?" "a boolean" } } { $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ; - -HELP: can-write? -{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } } -{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ; From a2fa1369b04c867720ffcd360fa0c3016a225560 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 04:00:57 -0500 Subject: [PATCH 10/71] Furnace fixes --- extra/furnace/actions/actions.factor | 2 +- extra/furnace/furnace.factor | 3 ++- extra/furnace/sessions/sessions.factor | 8 ++++++-- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 2b3144fd27..9cc1880cc3 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -76,7 +76,7 @@ TUPLE: action rest authorize init display validate submit ; : handle-post ( action -- response ) '[ - form-nesting-key params get at " " split + form-nesting-key params get at " " split harvest [ , (handle-post) ] [ swap '[ , , nest-values ] ] reduce call diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 2645146fbf..a51841d4ad 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -109,7 +109,8 @@ SYMBOL: exit-continuation [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; : a-url-path ( tag -- string ) - [ "href" required-attr ] [ "rest" optional-attr value ] bi + [ "href" required-attr ] + [ "rest" optional-attr dup [ value ] when ] bi [ [ "/" ?tail drop "/" ] dip present 3append ] when* ; : a-url ( tag -- url ) diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index ab971d24d0..4be7403e39 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math.intervals math.parser namespaces random accessors quotations hashtables sequences continuations -fry calendar combinators destructors alarms io.server +fry calendar combinators combinators.lib destructors alarms io.server db db.tuples db.types http http.server http.server.dispatchers http.server.filters html.elements @@ -69,7 +69,11 @@ TUPLE: sessions < server-state-manager domain verify? ; : touch-session ( session -- ) sessions get touch-state ; -: remote-host ( -- string ) remote-address get host>> ; +: remote-host ( -- string ) + { + [ request get "x-forwarded-for" header ] + [ remote-address get host>> ] + } 0|| ; : empty-session ( -- session ) f From 198b1a0d56510f8ac75af900c8ec4338223f3b43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 04:01:07 -0500 Subject: [PATCH 11/71] Clean up quadratic --- extra/math/quadratic/quadratic.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/math/quadratic/quadratic.factor b/extra/math/quadratic/quadratic.factor index 2253582623..60929b92cb 100644 --- a/extra/math/quadratic/quadratic.factor +++ b/extra/math/quadratic/quadratic.factor @@ -3,13 +3,13 @@ USING: kernel math math.functions ; IN: math.quadratic -: monic ( c b a -- c' b' ) tuck / >r / r> ; +: monic ( c b a -- c' b' ) tuck [ / ] 2bi@ ; : discriminant ( c b -- b d ) tuck sq 4 / swap - sqrt ; -: critical ( b d -- -b/2 d ) >r -2 / r> ; +: critical ( b d -- -b/2 d ) [ -2 / ] dip ; -: +- ( x y -- x+y x-y ) [ + ] 2keep - ; +: +- ( x y -- x+y x-y ) [ + ] [ - ] 2bi ; : quadratic ( c b a -- alpha beta ) #! Solve a quadratic equation ax^2 + bx + c = 0 @@ -17,4 +17,4 @@ IN: math.quadratic : qeval ( x c b a -- y ) #! Evaluate ax^2 + bx + c - >r pick * r> roll sq * + + ; + [ pick * ] dip roll sq * + + ; From 149e4345c6d581e2088bc9a8bab2cb32f9d8cf8d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 04:01:16 -0500 Subject: [PATCH 12/71] Add sanity checks --- extra/html/components/components.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index 6e1a25f5f5..7355cd153d 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -10,9 +10,12 @@ IN: html.components SYMBOL: values -: value ( name -- value ) values get at ; +: check-value-name ( name -- name ) + dup string? [ "Value name not a string" throw ] unless ; -: set-value ( value name -- ) values get set-at ; +: value ( name -- value ) check-value-name values get at ; + +: set-value ( value name -- ) check-value-name values get set-at ; : blank-values ( -- ) H{ } clone values set ; From 501588ab76622b3ab7882a4d385b0c628706e597 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 04:01:25 -0500 Subject: [PATCH 13/71] add x-forwarded-for logging --- extra/http/server/server.factor | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 095b52171c..03822ec854 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -78,9 +78,15 @@ main-responder global [ <404> or ] change-at LOG: httpd-hit NOTICE +LOG: httpd-header NOTICE + +: log-header ( headers name -- ) + tuck header 2array httpd-header ; + : log-request ( request -- ) - [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi - 3array httpd-hit ; + [ [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ] + [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ] + bi ; : split-path ( string -- path ) "/" split harvest ; From 5692d28ce5cdd47aff5cc906c08706bedf2b466b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 04:06:43 -0500 Subject: [PATCH 14/71] Fix compile error --- extra/editors/vim/vim.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor index 9ce256868b..8ec94a7fd6 100755 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -6,11 +6,11 @@ SYMBOL: vim-path SYMBOL: vim-detach SYMBOL: vim-editor -HOOK: vim-command vim-editor +HOOK: vim-command vim-editor ( file line -- array ) TUPLE: vim ; -M: vim vim-command ( file line -- array ) +M: vim vim-command [ vim-path get , swap , "+" swap number>string append , ] { } make ; From b8380711e459fb27cd36d6f5c70c4662d2f79133 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 04:11:30 -0500 Subject: [PATCH 15/71] Clean up editors.vim/gvim a bit --- extra/editors/gvim/gvim.factor | 6 +++--- extra/editors/vim/vim.factor | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor index 62150bdf49..240af7d8ef 100755 --- a/extra/editors/gvim/gvim.factor +++ b/extra/editors/gvim/gvim.factor @@ -3,14 +3,14 @@ namespaces sequences system combinators editors.vim editors.gvim.backend vocabs.loader ; IN: editors.gvim -TUPLE: gvim ; +SINGLETON: gvim M: gvim vim-command ( file line -- string ) - [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ; + [ gvim-path , swap , "+" swap number>string append , ] { } make ; t vim-detach set-global ! don't block the ui -T{ gvim } vim-editor set-global +gvim vim-editor set-global { { [ os unix? ] [ "editors.gvim.unix" ] } diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor index 8ec94a7fd6..29c16f7cc3 100755 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -8,7 +8,7 @@ SYMBOL: vim-detach SYMBOL: vim-editor HOOK: vim-command vim-editor ( file line -- array ) -TUPLE: vim ; +SINGLETON: vim M: vim vim-command [ @@ -23,4 +23,4 @@ M: vim vim-command "vim" vim-path set-global [ vim-location ] edit-hook set-global -T{ vim } vim-editor set-global +vim vim-editor set-global From bd7bee867b15c35be5477a4874c27d1806d12af3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 04:18:29 -0500 Subject: [PATCH 16/71] Fix test failure --- extra/html/components/components-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 2ae120b527..8ec3a58611 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -156,7 +156,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ ] [ "-foo\n-bar" "farkup" set-value ] unit-test [ "
  • foo
  • bar
" ] [ - [ "farkup" farkup render ] with-string-writer + [ "farkup" T{ farkup } render ] with-string-writer ] unit-test [ ] [ { 1 2 3 } "object" set-value ] unit-test From 5b4809e49d36d9ab8129912c874ed0c69525ff2e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jun 2008 04:21:52 -0500 Subject: [PATCH 17/71] Remove dead code --- extra/editors/gvim/gvim.factor | 2 -- extra/editors/vim/vim-docs.factor | 4 +--- extra/editors/vim/vim.factor | 6 +----- 3 files changed, 2 insertions(+), 10 deletions(-) diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor index 240af7d8ef..041f3db675 100755 --- a/extra/editors/gvim/gvim.factor +++ b/extra/editors/gvim/gvim.factor @@ -8,8 +8,6 @@ SINGLETON: gvim M: gvim vim-command ( file line -- string ) [ gvim-path , swap , "+" swap number>string append , ] { } make ; -t vim-detach set-global ! don't block the ui - gvim vim-editor set-global { diff --git a/extra/editors/vim/vim-docs.factor b/extra/editors/vim/vim-docs.factor index 020117564d..cf42884084 100644 --- a/extra/editors/vim/vim-docs.factor +++ b/extra/editors/vim/vim-docs.factor @@ -11,7 +11,5 @@ $nl "USE: vim" "\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global" } -"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." -$nl -"If you are running the terminal version of Vim, you want it to block Factor until exiting, but for GVim the opposite is desired, so that one can work in Factor and GVim concurrently. The " { $link vim-detach } " global variable can be set to " { $link t } " to detach the Vim process. The default is " { $link f } "." ; +"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ; diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor index 29c16f7cc3..bfbb8f15a5 100755 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -3,7 +3,6 @@ namespaces parser prettyprint sequences editors accessors ; IN: editors.vim SYMBOL: vim-path -SYMBOL: vim-detach SYMBOL: vim-editor HOOK: vim-command vim-editor ( file line -- array ) @@ -16,10 +15,7 @@ M: vim vim-command ] { } make ; : vim-location ( file line -- ) - vim-command - swap >>command - vim-detach get-global [ t >>detached ] when - try-process ; + vim-command try-process ; "vim" vim-path set-global [ vim-location ] edit-hook set-global From 10477bf7dd3c9b60341ab65da76313797ba0ebae Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 14 Jun 2008 13:09:54 -0500 Subject: [PATCH 18/71] newfx: a few additions --- extra/newfx/newfx.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index be30dfe370..0504744240 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -189,4 +189,9 @@ METHOD: as-mutate { object object assoc } set-at ; ! A note about the 'mutate' qualifier. Other words also technically mutate ! their primary object. However, the 'mutate' qualifier is supposed to -! indicate that this is the main objective of the word, as a side effect. \ No newline at end of file +! indicate that this is the main objective of the word, as a side effect. + +: adjoin ( seq elt -- seq ) over sets:adjoin ; +: adjoin-on ( elt seq -- seq ) sets:adjoin ; +: adjoined ( set elt -- set ) swap sets:adjoin ; +: adjoined-on ( elt set -- ) sets:adjoin ; \ No newline at end of file From a36307a11b7f4d4a1cb60cb7d4a33d2910a70916 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 14 Jun 2008 14:44:32 -0500 Subject: [PATCH 19/71] newfx: minor fix --- extra/newfx/newfx.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index 0504744240..e7d92bba58 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -192,6 +192,6 @@ METHOD: as-mutate { object object assoc } set-at ; ! indicate that this is the main objective of the word, as a side effect. : adjoin ( seq elt -- seq ) over sets:adjoin ; -: adjoin-on ( elt seq -- seq ) sets:adjoin ; -: adjoined ( set elt -- set ) swap sets:adjoin ; +: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ; +: adjoined ( set elt -- ) swap sets:adjoin ; : adjoined-on ( elt set -- ) sets:adjoin ; \ No newline at end of file From 094cb776fb8dd994ca8bd60dccd0870cbcabdd4e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 14 Jun 2008 14:45:37 -0500 Subject: [PATCH 20/71] dns.server: add CNAME to rr->rdata-names --- extra/dns/server/server.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index de36d661aa..7d52ff9e88 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -50,9 +50,10 @@ IN: dns.server : rr->rdata-names ( rr -- names/f ) { - { [ dup type>> NS = ] [ rdata>> {1} ] } - { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] } - { [ t ] [ drop f ] } + { [ dup type>> NS = ] [ rdata>> {1} ] } + { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] } + { [ dup type>> CNAME = ] [ rdata>> {1} ] } + { [ t ] [ drop f ] } } cond ; From b8f1d71d2eb6874ae81a42fdef1855bd8eb6ac75 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 14 Jun 2008 15:48:07 -0500 Subject: [PATCH 21/71] dns.server: do work in separate thread --- extra/dns/server/server.factor | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index 7d52ff9e88..b556780805 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -1,8 +1,8 @@ -USING: kernel combinators sequences sets math +USING: kernel combinators sequences sets math threads io.sockets unicode.case accessors combinators.cleave combinators.lib - newfx + newfx fry dns dns.util dns.misc ; IN: dns.server @@ -204,15 +204,18 @@ DEFER: query->rrs ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: loop ( -- ) - socket receive - swap +: (handle-request) ( byte-array addr-spec -- ) + >r parse-message find-answer message->ba - swap - socket send - loop ; + r> + socket send ; + +: handle-request ( byte-array addr-spec -- ) + '[ , , (handle-request) ] in-thread ; + +: loop ( -- ) socket receive handle-request loop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 3e6a6c2195b29c7ce3d3ec84ce14ca346c756984 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 14 Jun 2008 16:05:38 -0500 Subject: [PATCH 22/71] newfx: minor fix --- extra/newfx/newfx.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index e7d92bba58..37c738cd6a 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -1,11 +1,12 @@ -USING: kernel sequences assocs qualified circular ; +USING: kernel sequences assocs qualified circular sets ; USING: math multi-methods ; QUALIFIED: sequences QUALIFIED: assocs QUALIFIED: circular +QUALIFIED: sets IN: newfx From 229ad789071e2485eef9773deeb528d521faa835 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 00:32:48 -0500 Subject: [PATCH 23/71] Slight cleanup --- core/assocs/assocs.factor | 21 ++++++++++----------- core/sequences/sequences.factor | 7 ++++--- extra/sequences/lib/lib.factor | 3 --- 3 files changed, 14 insertions(+), 17 deletions(-) diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index c875475278..f56ac810d9 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -20,26 +20,25 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: >alist ( assoc -- newassoc ) +: (assoc-each) ( assoc quot -- seq quot' ) + >r >alist r> [ first2 ] prepose ; inline + : assoc-find ( assoc quot -- key value ? ) - >r >alist r> [ first2 ] prepose find swap - [ first2 t ] [ drop f f f ] if ; inline + (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline : key? ( key assoc -- ? ) at* nip ; inline : assoc-each ( assoc quot -- ) - [ f ] compose assoc-find 3drop ; inline - -: (assoc>map) ( quot accum -- quot' ) - [ push ] curry compose ; inline + (assoc-each) each ; inline : assoc>map ( assoc quot exemplar -- seq ) - >r over assoc-size - [ (assoc>map) assoc-each ] keep - r> like ; inline + >r accumulator >r assoc-each r> r> like ; inline + +: assoc-map-as ( assoc quot exemplar -- newassoc ) + >r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline : assoc-map ( assoc quot -- newassoc ) - over >r [ 2array ] compose V{ } assoc>map r> assoc-like ; - inline + over assoc-map-as ; inline : assoc-push-if ( key value quot accum -- ) >r 2keep r> roll diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index cb33552693..02a7191f0a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -419,10 +419,11 @@ PRIVATE> : interleave ( seq between quot -- ) [ (interleave) ] 2curry >r dup length swap r> 2each ; inline +: accumulator ( quot -- quot' vec ) + V{ } clone [ [ push ] curry compose ] keep ; inline + : unfold ( pred quot tail -- seq ) - V{ } clone [ - swap >r [ push ] curry compose r> while - ] keep { } like ; inline + swap accumulator >r swap while r> { } like ; inline : follow ( obj quot -- seq ) >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ed4c337a92..56488818ab 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -201,9 +201,6 @@ USE: continuations >r >r 0 max r> r> [ length tuck min >r min r> ] keep subseq ; -: accumulator ( quot -- quot vec ) - V{ } clone [ [ push ] curry compose ] keep ; inline - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! List the positions of obj in seq From 292a6fdb0d9af33c193e37881260ab7327527db3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 02:37:28 -0500 Subject: [PATCH 24/71] Fix typo --- extra/cords/cords.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/cords/cords.factor b/extra/cords/cords.factor index f5cc89f8d5..a7f4246826 100644 --- a/extra/cords/cords.factor +++ b/extra/cords/cords.factor @@ -1,4 +1,4 @@ -! Copysecond (C) 2008 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences sorting math math.order arrays combinators kernel ; From 0f2da40977fbf6160d3e2908ddad1b3cf43c43c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 02:37:37 -0500 Subject: [PATCH 25/71] Better error message --- extra/io/launcher/launcher.factor | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 131cadfaf0..bd90072039 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.ports ; +io.streams.duplex io.ports debugger prettyprint inspector ; IN: io.launcher TUPLE: process < identity-tuple @@ -131,11 +131,16 @@ HOOK: run-process* io-backend ( process -- handle ) run-detached dup detached>> [ dup wait-for-process drop ] unless ; -ERROR: process-failed code ; +ERROR: process-failed process code ; + +M: process-failed error. + dup "Process exited with error code " write code>> . nl + "Launch descriptor:" print nl + process>> describe ; : try-process ( desc -- ) - run-process wait-for-process dup zero? - [ drop ] [ process-failed ] if ; + run-process dup wait-for-process dup zero? + [ 2drop ] [ process-failed ] if ; HOOK: kill-process* io-backend ( handle -- ) From 0ab3f1f436d11f860dad64c71f6f35d9f44d9182 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 02:38:12 -0500 Subject: [PATCH 26/71] New html.forms abstraction fixes some problems; clean up some code --- extra/furnace/actions/actions.factor | 67 ++++++----- extra/furnace/auth/login/login.factor | 8 +- extra/furnace/flash/flash.factor | 4 +- extra/furnace/furnace.factor | 5 +- extra/html/components/components-tests.factor | 21 ++-- extra/html/components/components.factor | 89 +++------------ extra/html/forms/forms-tests.factor | 67 +++++++++++ extra/html/forms/forms.factor | 106 ++++++++++++++++++ extra/html/templates/chloe/chloe-tests.factor | 10 +- extra/html/templates/chloe/chloe.factor | 3 +- extra/http/http-tests.factor | 3 +- extra/validators/validators-tests.factor | 64 ----------- extra/validators/validators.factor | 54 +-------- extra/webapps/blogs/blogs.factor | 12 +- extra/webapps/pastebin/pastebin.factor | 13 ++- extra/webapps/planet/planet.factor | 6 +- extra/webapps/todo/todo.factor | 5 +- extra/webapps/user-admin/edit-user.xml | 4 +- extra/webapps/user-admin/user-admin.factor | 38 +++++-- 19 files changed, 310 insertions(+), 269 deletions(-) create mode 100644 extra/html/forms/forms-tests.factor create mode 100644 extra/html/forms/forms.factor diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 9cc1880cc3..4b431c83bc 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -8,6 +8,7 @@ http.server http.server.responses furnace furnace.flash +html.forms html.elements html.components html.components @@ -20,10 +21,10 @@ SYMBOL: params SYMBOL: rest : render-validation-messages ( -- ) - validation-messages get + form get errors>> dup empty? [ drop ] [
    - [
  • message>> escape-string write
    • ] each + [
  • escape-string write
    • ] each
] if ; @@ -37,8 +38,21 @@ TUPLE: action rest authorize init display validate submit ; : ( -- action ) action new-action ; -: flashed-variables ( -- seq ) - { validation-messages named-validation-messages } ; +: set-nested-form ( form name -- ) + dup empty? [ + drop form set + ] [ + dup length 1 = [ + first set-value + ] [ + unclip [ set-nested-form ] nest-form + ] if + ] if ; + +: restore-validation-errors ( -- ) + form fget [ + nested-forms fget set-nested-form + ] when* ; : handle-get ( action -- response ) '[ @@ -46,25 +60,12 @@ TUPLE: action rest authorize init display validate submit ; { [ init>> call ] [ authorize>> call ] - [ drop flashed-variables restore-flash ] + [ drop restore-validation-errors ] [ display>> call ] } cleave ] [ drop <400> ] if ] with-exit-continuation ; -: validation-failed ( -- * ) - post-request? [ f ] [ <400> ] if exit-with ; - -: (handle-post) ( action -- response ) - '[ - , dup submit>> [ - [ validate>> call ] - [ authorize>> call ] - [ submit>> call ] - tri - ] [ drop <400> ] if - ] with-exit-continuation ; - : param ( name -- value ) params get at ; @@ -74,24 +75,29 @@ TUPLE: action rest authorize init display validate submit ; revalidate-url-key param dup [ >url [ same-host? ] keep and ] when ; +: validation-failed ( -- * ) + post-request? revalidate-url and + [ + nested-forms-key param " " split harvest nested-forms set + { form nested-forms } + ] [ <400> ] if* + exit-with ; + : handle-post ( action -- response ) '[ - form-nesting-key params get at " " split harvest - [ , (handle-post) ] - [ swap '[ , , nest-values ] ] reduce - call - ] with-exit-continuation - [ - revalidate-url - [ flashed-variables ] [ <403> ] if* - ] unless* ; + , dup submit>> [ + [ validate>> call ] + [ authorize>> call ] + [ submit>> call ] + tri + ] [ drop <400> ] if + ] with-exit-continuation ; : handle-rest ( path action -- assoc ) rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ; : init-action ( path action -- ) - blank-values - init-validation + begin-form handle-rest request get request-params assoc-union params set ; @@ -110,8 +116,7 @@ M: action modify-form validation-failed? [ validation-failed ] when ; : validate-params ( validators -- ) - params get swap validate-values from-object - check-validation ; + params get swap validate-values check-validation ; : validate-integer-id ( -- ) { { "id" [ v-number ] } } validate-params ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index a1d2bf47c3..80005c452a 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -13,6 +13,7 @@ destructors checksums checksums.sha2 validators +html.forms html.components html.elements urls @@ -34,13 +35,16 @@ QUALIFIED: smtp IN: furnace.auth.login : word>string ( word -- string ) - [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; + [ word-vocabulary ] [ word-name ] bi ":" swap 3append ; : words>strings ( seq -- seq' ) [ word>string ] map ; +ERROR: no-such-word name vocab ; + : string>word ( string -- word ) - ":" split1 swap lookup ; + ":" split1 swap 2dup lookup dup + [ 2nip ] [ drop no-such-word ] if ; : strings>words ( seq -- seq' ) [ string>word ] map ; diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor index 43e0d293a5..e06cdac090 100644 --- a/extra/furnace/flash/flash.factor +++ b/extra/furnace/flash/flash.factor @@ -25,7 +25,9 @@ TUPLE: flash-scopes < server-state-manager ; SYMBOL: flash-scope -: fget ( key -- value ) flash-scope get at ; +: fget ( key -- value ) + flash-scope get dup + [ namespace>> at ] [ 2drop f ] if ; : get-flash-scope ( id -- flash-scope ) dup [ flash-scope get-state ] when diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index a51841d4ad..e9d1b29da8 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -10,6 +10,7 @@ xml.entities xml.writer html.components html.elements +html.forms html.templates html.templates.chloe html.templates.chloe.syntax @@ -154,11 +155,11 @@ CHLOE: a input/> ] [ 2drop ] if ; -: form-nesting-key "__n" ; +: nested-forms-key "__n" ; : form-magic ( tag -- ) [ modify-form ] each-responder - nested-values get " " join f like form-nesting-key hidden-form-field + nested-forms get " " join f like nested-forms-key hidden-form-field "for" optional-attr [ "," split [ hidden render ] each ] when* ; : form-start-tag ( tag -- ) diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 8ec3a58611..5779371078 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -1,9 +1,9 @@ IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams -html.elements html.components namespaces ; +html.elements html.components html.forms namespaces ; -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ 3 "hi" set-value ] unit-test @@ -63,7 +63,7 @@ TUPLE: color red green blue ; ] with-null-writer ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ "new york" "city1" set-value ] unit-test @@ -101,7 +101,7 @@ TUPLE: color red green blue ; ] with-null-writer ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ t "delivery" set-value ] unit-test @@ -167,12 +167,19 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; = ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ "factor" [ "concatenative" "model" set-value - ] nest-values + ] nest-form ] unit-test -[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test +[ + H{ + { + "factor" + T{ form f V{ } H{ { "model" "concatenative" } } } + } + } +] [ values ] unit-test diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index 7355cd153d..b6b7f22b1d 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -1,85 +1,26 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces io math.parser assocs classes -classes.tuple words arrays sequences sequences.lib splitting -mirrors hashtables combinators continuations math strings -fry locals calendar calendar.format xml.entities validators -html.elements html.streams xmode.code2html farkup inspector -lcs.diff2html urls present ; +classes.tuple words arrays sequences splitting mirrors +hashtables combinators continuations math strings inspector +fry locals calendar calendar.format xml.entities +validators urls present +xmode.code2html lcs.diff2html farkup +html.elements html.streams html.forms ; IN: html.components -SYMBOL: values - -: check-value-name ( name -- name ) - dup string? [ "Value name not a string" throw ] unless ; - -: value ( name -- value ) check-value-name values get at ; - -: set-value ( value name -- ) check-value-name values get set-at ; - -: blank-values ( -- ) H{ } clone values set ; - -: prepare-value ( name object -- value name object ) - [ [ value ] keep ] dip ; inline - -: from-object ( object -- ) - dup assoc? [ ] unless - values get swap update ; - -: deposit-values ( destination names -- ) - [ dup value ] H{ } map>assoc update ; - -: deposit-slots ( destination names -- ) - [ ] dip deposit-values ; - -: with-each-value ( name quot -- ) - [ value ] dip '[ - [ - values [ clone ] change - 1+ "index" set-value - "value" set-value - @ - ] with-scope - ] each-index ; inline - -: with-each-object ( name quot -- ) - [ value ] dip '[ - [ - blank-values - 1+ "index" set-value - from-object - @ - ] with-scope - ] each-index ; inline - -SYMBOL: nested-values - -: with-values ( name quot -- ) - '[ - , - [ nested-values [ swap prefix ] change ] - [ value blank-values from-object ] - bi - @ - ] with-scope ; inline - -: nest-values ( name quot -- ) - swap [ - [ - H{ } clone [ values set call ] keep - ] with-scope - ] dip set-value ; inline - GENERIC: render* ( value name render -- ) : render ( name renderer -- ) - over named-validation-messages get at [ - [ value>> ] [ message>> ] bi - [ -rot render* ] dip - render-error - ] [ - prepare-value render* - ] if* ; + prepare-value + [ + dup validation-error? + [ [ message>> ] [ value>> ] bi ] + [ f swap ] + if + ] 2dip + render* + [ render-error ] when* ; > "140" = ] + bi and + ] with-validation +] unit-test + +TUPLE: person name age ; + +person { + { "name" [ ] } + { "age" [ v-number 13 v-min-value 100 v-max-value ] } +} define-validators + +[ t t ] [ + [ + { { "age" "" } } + { { "age" [ v-required ] } } + validate-values + validation-failed? + "age" value + [ validation-error? ] + [ message>> "required" = ] + bi and + ] with-validation +] unit-test + +[ H{ { "a" 123 } } f ] [ + [ + H{ + { "a" "123" } + { "b" "c" } + { "c" "d" } + } + H{ + { "a" [ v-integer ] } + } validate-values + values + validation-failed? + ] with-validation +] unit-test + +[ t "foo" ] [ + [ + "foo" validation-error + validation-failed? + form get errors>> first + ] with-validation +] unit-test diff --git a/extra/html/forms/forms.factor b/extra/html/forms/forms.factor new file mode 100644 index 0000000000..0da3fcb0b3 --- /dev/null +++ b/extra/html/forms/forms.factor @@ -0,0 +1,106 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors strings namespaces assocs hashtables +mirrors math fry sequences sequences.lib words continuations ; +IN: html.forms + +TUPLE: form errors values validation-failed ; + +:
( -- form ) + form new + V{ } clone >>errors + H{ } clone >>values ; + +M: form clone + call-next-method + [ clone ] change-errors + [ clone ] change-values ; + +: check-value-name ( name -- name ) + dup string? [ "Value name not a string" throw ] unless ; + +: values ( -- assoc ) + form get values>> ; + +: value ( name -- value ) + check-value-name values at ; + +: set-value ( value name -- ) + check-value-name values set-at ; + +: begin-form ( -- ) form set ; + +: prepare-value ( name object -- value name object ) + [ [ value ] keep ] dip ; inline + +: from-object ( object -- ) + [ values ] [ make-mirror ] bi* update ; + +: to-object ( destination names -- ) + [ make-mirror ] [ values extract-keys ] bi* update ; + +: with-each-value ( name quot -- ) + [ value ] dip '[ + [ + form [ clone ] change + 1+ "index" set-value + "value" set-value + @ + ] with-scope + ] each-index ; inline + +: with-each-object ( name quot -- ) + [ value ] dip '[ + [ + begin-form + 1+ "index" set-value + from-object + @ + ] with-scope + ] each-index ; inline + +SYMBOL: nested-forms + +: with-form ( name quot -- ) + '[ + , + [ nested-forms [ swap prefix ] change ] + [ value form set ] + bi + @ + ] with-scope ; inline + +: nest-form ( name quot -- ) + swap [ + [ + form set + call + form get + ] with-scope + ] dip set-value ; inline + +TUPLE: validation-error value message ; + +C: validation-error + +: validation-error ( message -- ) + form get + t >>validation-failed + errors>> push ; + +: validation-failed? ( -- ? ) + form get validation-failed>> ; + +: define-validators ( class validators -- ) + >hashtable "validators" set-word-prop ; + +: validate ( value quot -- result ) + [ ] recover ; inline + +: validate-value ( name value quot -- ) + validate + dup validation-error? [ form get t >>validation-failed drop ] when + swap set-value ; + +: validate-values ( assoc validators -- assoc' ) + swap '[ dup , at _ validate-value ] assoc-each ; diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 433aedbc9a..87ba37ed9e 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -9,13 +9,13 @@ IN: html.templates.chloe.tests [ f ] [ "" parse-query-attr ] unit-test [ H{ { "a" "b" } } ] [ - blank-values + begin-form "b" "a" set-value "a" parse-query-attr ] unit-test [ H{ { "a" "b" } { "c" "d" } } ] [ - blank-values + begin-form "b" "a" set-value "d" "c" set-value "a,c" parse-query-attr @@ -69,7 +69,7 @@ IN: html.templates.chloe.tests ] run-template ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ "A label" "label" set-value ] unit-test @@ -157,7 +157,7 @@ TUPLE: person first-name last-name ; ] run-template ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value @@ -170,7 +170,7 @@ TUPLE: person first-name last-name ; ] unit-test [ ] [ - blank-values + begin-form { "a" "b" } "choices" set-value "true" "b" set-value ] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 936c06ae7e..32fe954178 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -5,6 +5,7 @@ classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string unicode.case tuple-syntax mirrors fry math urls present multiline xml xml.data xml.writer xml.utilities +html.forms html.elements html.components html.templates @@ -76,7 +77,7 @@ CHLOE: each [ with-each-value ] (bind-tag) ; CHLOE: bind-each [ with-each-object ] (bind-tag) ; -CHLOE: bind [ with-values ] (bind-tag) ; +CHLOE: bind [ with-form ] (bind-tag) ; : error-message-tag ( tag -- ) children>string render-error ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index bc206f08b7..88d42d9796 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -223,7 +223,8 @@ test-db [ [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test -USING: html.components html.elements xml xml.utilities validators +USING: html.components html.elements html.forms +xml xml.utilities validators furnace furnace.flash ; SYMBOL: a diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor index 7d4325cbb6..bd24323f20 100644 --- a/extra/validators/validators-tests.factor +++ b/extra/validators/validators-tests.factor @@ -2,14 +2,6 @@ IN: validators.tests USING: kernel sequences tools.test validators accessors namespaces assocs ; -: with-validation ( quot -- messages ) - [ - init-validation - call - validation-messages get - named-validation-messages get >alist append - ] with-scope ; inline - [ "" v-one-line ] must-fail [ "hello world" ] [ "hello world" v-one-line ] unit-test [ "hello\nworld" v-one-line ] must-fail @@ -60,59 +52,3 @@ namespaces assocs ; [ "4561_2612_1234_5467" v-credit-card ] must-fail [ "4561-2621-1234-5467" v-credit-card ] must-fail - - -[ 14 V{ } ] [ - [ - "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate - ] with-validation -] unit-test - -[ f t ] [ - [ - "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate - ] with-validation first - [ first "age" = ] - [ second validation-error? ] - [ second value>> "140" = ] - tri and and -] unit-test - -TUPLE: person name age ; - -person { - { "name" [ ] } - { "age" [ v-number 13 v-min-value 100 v-max-value ] } -} define-validators - -[ t t ] [ - [ - { { "age" "" } } required-values - validation-failed? - ] with-validation first - [ first "age" = ] - [ second validation-error? ] - [ second message>> "required" = ] - tri and and -] unit-test - -[ H{ { "a" 123 } } f V{ } ] [ - [ - H{ - { "a" "123" } - { "b" "c" } - { "c" "d" } - } - H{ - { "a" [ v-integer ] } - } validate-values - validation-failed? - ] with-validation -] unit-test - -[ t "foo" ] [ - [ - "foo" validation-error - validation-failed? - ] with-validation first message>> -] unit-test diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor index aeb2dc2f80..37c0216740 100644 --- a/extra/validators/validators.factor +++ b/extra/validators/validators.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences sequences.lib math -namespaces sets math.parser math.ranges assocs regexp fry -unicode.categories arrays hashtables words combinators mirrors +namespaces sets math.parser math.ranges assocs regexp +unicode.categories arrays hashtables words classes quotations xmode.catalog ; IN: validators @@ -107,53 +107,3 @@ IN: validators ] [ "invalid credit card number format" throw ] if ; - -SYMBOL: validation-messages -SYMBOL: named-validation-messages - -: init-validation ( -- ) - V{ } clone validation-messages set - H{ } clone named-validation-messages set ; - -: (validation-message) ( obj -- ) - validation-messages get push ; - -: (validation-message-for) ( obj name -- ) - named-validation-messages get set-at ; - -TUPLE: validation-message message ; - -C: validation-message - -: validation-message ( string -- ) - (validation-message) ; - -: validation-message-for ( string name -- ) - [ ] dip (validation-message-for) ; - -TUPLE: validation-error message value ; - -C: validation-error - -: validation-error ( message -- ) - f (validation-message) ; - -: validation-error-for ( message value name -- ) - [ ] dip (validation-message-for) ; - -: validation-failed? ( -- ? ) - validation-messages get [ validation-error? ] contains? - named-validation-messages get [ nip validation-error? ] assoc-contains? - or ; - -: define-validators ( class validators -- ) - >hashtable "validators" set-word-prop ; - -: validate ( value name quot -- result ) - '[ drop @ ] [ -rot validation-error-for f ] recover ; inline - -: required-values ( assoc -- ) - [ swap [ v-required ] validate drop ] assoc-each ; - -: validate-values ( assoc validators -- assoc' ) - swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ; diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index d0c651c71f..760951eec6 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -1,8 +1,10 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sorting math.order math.parser -urls validators html.components db db.types db.tuples calendar -present http.server.dispatchers +urls validators db db.types db.tuples calendar present +html.forms +html.components +http.server.dispatchers furnace furnace.actions furnace.auth @@ -142,7 +144,7 @@ M: comment entity-url "id" value "new-comment" [ "parent" set-value - ] nest-values + ] nest-form ] >>init { blogs "view-post" } >>template ; @@ -163,7 +165,7 @@ M: comment entity-url [ f - dup { "title" "content" } deposit-slots + dup { "title" "content" } to-object uid >>author now >>date [ insert-tuple ] [ entity-url ] bi @@ -195,7 +197,7 @@ M: comment entity-url [ "id" value - dup { "title" "author" "date" "content" } deposit-slots + dup { "title" "author" "date" "content" } to-object [ update-tuple ] [ entity-url ] bi ] >>submit diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index d381adafcd..251872d1ac 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -4,6 +4,7 @@ USING: namespaces assocs sorting sequences kernel accessors hashtables sequences.lib db.types db.tuples db combinators calendar calendar.format math.parser syndication urls xml.writer xmode.catalog validators +html.forms html.components html.templates.chloe http.server @@ -126,7 +127,7 @@ M: annotation entity-url "parent" set-value mode-names "modes" set-value "factor" "mode" set-value - ] nest-values + ] nest-form ] >>init { pastebin "paste" } >>template ; @@ -149,7 +150,7 @@ M: annotation entity-url : deposit-entity-slots ( tuple -- ) now >>date - { "summary" "author" "mode" "contents" } deposit-slots ; + { "summary" "author" "mode" "contents" } to-object ; : ( -- action ) @@ -160,11 +161,12 @@ M: annotation entity-url { pastebin "new-paste" } >>template - [ mode-names "modes" set-value ] >>validate + [ + mode-names "modes" set-value + validate-entity + ] >>validate [ - validate-entity - f [ deposit-entity-slots ] [ insert-tuple ] @@ -196,6 +198,7 @@ M: annotation entity-url : ( -- action ) [ + mode-names "modes" set-value { { "parent" [ v-integer ] } } validate-params validate-entity ] >>validate diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 90b2411fc1..b472881e73 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -3,9 +3,9 @@ USING: kernel accessors sequences sorting math math.order calendar alarms logging concurrency.combinators namespaces sequences.lib db.types db.tuples db fry locals hashtables +syndication urls xml.writer validators +html.forms html.components -syndication urls xml.writer -validators http.server http.server.dispatchers furnace @@ -130,7 +130,7 @@ posting "POSTINGS" } validate-params ; : deposit-blog-slots ( blog -- ) - { "name" "www-url" "feed-url" } deposit-slots ; + { "name" "www-url" "feed-url" } to-object ; : ( -- action ) diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 0770765754..dba10184f4 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences namespaces db db.types db.tuples validators hashtables urls +html.forms html.components html.templates.chloe http.server @@ -62,7 +63,7 @@ todo "TODO" [ f - dup { "summary" "priority" "description" } deposit-slots + dup { "summary" "priority" "description" } to-object [ insert-tuple ] [ id>> view-todo-url ] bi ] >>submit ; @@ -82,7 +83,7 @@ todo "TODO" [ f - dup { "id" "summary" "priority" "description" } deposit-slots + dup { "id" "summary" "priority" "description" } to-object [ update-tuple ] [ id>> view-todo-url ] bi ] >>submit ; diff --git a/extra/webapps/user-admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml index 0c55f8ca76..252667462b 100644 --- a/extra/webapps/user-admin/edit-user.xml +++ b/extra/webapps/user-admin/edit-user.xml @@ -50,11 +50,11 @@

- +

- Delete + Delete diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 19153e1354..5859d616ee 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors namespaces combinators words assocs db.tuples arrays splitting strings validators urls +html.forms html.elements html.components furnace @@ -26,10 +27,19 @@ TUPLE: user-admin < dispatcher ; : init-capabilities ( -- ) capabilities get words>strings "capabilities" set-value ; -: selected-capabilities ( -- seq ) +: validate-capabilities ( -- ) "capabilities" value - [ param empty? not ] filter - [ string>word ] map ; + [ [ param empty? not ] keep set-value ] each ; + +: selected-capabilities ( -- seq ) + "capabilities" value [ value ] filter [ string>word ] map ; + +: validate-user ( -- ) + { + { "username" [ v-username ] } + { "realname" [ [ v-one-line ] v-optional ] } + { "email" [ [ v-email ] v-optional ] } + } validate-params ; : ( -- action ) @@ -42,14 +52,13 @@ TUPLE: user-admin < dispatcher ; [ init-capabilities + validate-capabilities + + validate-user { - { "username" [ v-username ] } - { "realname" [ v-one-line ] } { "new-password" [ v-password ] } { "verify-password" [ v-password ] } - { "email" [ [ v-email ] v-optional ] } - { "capabilities" [ ] } } validate-params same-password-twice @@ -74,14 +83,16 @@ TUPLE: user-admin < dispatcher ; : validate-username ( -- ) { { "username" [ v-username ] } } validate-params ; +: select-capabilities ( seq -- ) + [ t swap word>string set-value ] each ; + : ( -- action ) [ validate-username "username" value select-tuple - [ from-object ] - [ capabilities>> [ "true" swap word>string set-value ] each ] bi + [ from-object ] [ capabilities>> select-capabilities ] bi init-capabilities ] >>init @@ -89,14 +100,17 @@ TUPLE: user-admin < dispatcher ; { user-admin "edit-user" } >>template [ + "username" value select-tuple + [ from-object ] [ capabilities>> select-capabilities ] bi + init-capabilities + validate-capabilities + + validate-user { - { "username" [ v-username ] } - { "realname" [ v-one-line ] } { "new-password" [ [ v-password ] v-optional ] } { "verify-password" [ [ v-password ] v-optional ] } - { "email" [ [ v-email ] v-optional ] } } validate-params "new-password" "verify-password" From ac4f180857d4dab42ee4123ee4236c34fb239849 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 03:25:36 -0500 Subject: [PATCH 27/71] Fix load errors --- extra/webapps/wee-url/wee-url.factor | 2 +- extra/webapps/wiki/wiki.factor | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index 29c4a60bef..2396e98b2a 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math.ranges sequences random accessors combinators.lib kernel namespaces fry db.types db.tuples urls validators -html.components http http.server.dispatchers furnace +html.components html.forms http http.server.dispatchers furnace furnace.actions furnace.boilerplate ; IN: webapps.wee-url diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 8dd62c8761..3183b48da9 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order present -html.components syndication +syndication +html.components html.forms http.server http.server.dispatchers furnace From 10a87fc0afd0c671350f7cbedd9f1dd57a8cdf2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 03:25:41 -0500 Subject: [PATCH 28/71] Fix compile errors --- extra/xmode/catalog/catalog.factor | 2 +- extra/xmode/loader/loader.factor | 8 ++++---- extra/xmode/loader/syntax/syntax.factor | 2 +- extra/xmode/utilities/utilities.factor | 3 +-- 4 files changed, 7 insertions(+), 8 deletions(-) diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 8c6025f726..98276caf83 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -5,7 +5,7 @@ IN: xmode.catalog TUPLE: mode file file-name-glob first-line-glob ; -r diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor index 5cf3675941..8039db0ac9 100755 --- a/extra/xmode/loader/loader.factor +++ b/extra/xmode/loader/loader.factor @@ -7,15 +7,15 @@ IN: xmode.loader ! Based on org.gjt.sp.jedit.XModeHandler ! RULES and its children -number swap set-rule-set-terminate-char ; RULE: SEQ seq-rule diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor index 175c8ed22f..b3adf5cb60 100644 --- a/extra/xmode/loader/syntax/syntax.factor +++ b/extra/xmode/loader/syntax/syntax.factor @@ -75,7 +75,7 @@ SYMBOL: ignore-case? [ parse-literal-matcher swap set-rule-end ] , ; ! SPAN's children - tag-handler-word get tag-handlers get >alist [ >r dup name-tag r> case ] curry - (( tag -- )) define-declared ; parsing + define ; parsing From 2b413f1eb7e1453c6fdc9384fe1ade468d77c0e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 04:56:15 -0500 Subject: [PATCH 29/71] Add request timing --- extra/http/server/server.factor | 27 ++++++++++++++++++--------- extra/io/server/server.factor | 10 +++++----- 2 files changed, 23 insertions(+), 14 deletions(-) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 03822ec854..dc66cb1507 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations -combinators tools.vocabs math +combinators tools.vocabs tools.time math io io.server io.sockets @@ -26,7 +26,9 @@ SYMBOL: responder-nesting SYMBOL: main-responder -SYMBOL: development-mode +SYMBOL: development? + +SYMBOL: benchmark? ! path is a sequence of path component strings GENERIC: call-responder* ( path responder -- response ) @@ -55,7 +57,7 @@ main-responder global [ <404> or ] change-at : <500> ( error -- response ) 500 "Internal server error" - swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; + swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) [ write-response ] @@ -69,7 +71,7 @@ main-responder global [ <404> or ] change-at ] [ utf8 [ - development-mode get + development? get [ http-error. ] [ drop "Response error" rethrow ] if ] with-encoded-output ] recover @@ -84,7 +86,7 @@ LOG: httpd-header NOTICE tuck header 2array httpd-header ; : log-request ( request -- ) - [ [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ] + [ [ method>> ] [ url>> ] bi 2array httpd-hit ] [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ] bi ; @@ -121,13 +123,20 @@ LOG: httpd-header NOTICE ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ; : ?refresh-all ( -- ) - development-mode get-global - [ global [ refresh-all ] bind ] when ; + development? get-global [ global [ refresh-all ] bind ] when ; : setup-limits ( -- ) 1 minutes timeouts 64 1024 * limit-input ; +LOG: httpd-benchmark DEBUG + +: ?benchmark ( quot -- ) + benchmark? get [ + [ benchmark ] [ first ] bi request get url>> rot 3array + httpd-benchmark + ] [ call ] if ; inline + : handle-client ( -- ) [ setup-limits @@ -135,8 +144,8 @@ LOG: httpd-header NOTICE ascii encode-output ?refresh-all read-request - do-request - do-response + [ do-request ] ?benchmark + [ do-response ] ?benchmark ] with-destructors ; : httpd ( port -- ) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index c855fba6be..e975880a14 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files io.streams.duplex logging continuations destructors kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar threads concurrency.combinators -assocs fry accessors ; +assocs fry accessors arrays ; IN: io.server SYMBOL: servers @@ -17,13 +17,13 @@ LOG: accepted-connection NOTICE : with-connection ( client remote local quot -- ) '[ - , [ remote-address set ] [ accepted-connection ] bi - , local-address set + , , + [ [ remote-address set ] [ local-address set ] bi* ] + [ 2array accepted-connection ] + 2bi @ ] with-stream ; inline -\ with-connection DEBUG add-error-logging - : accept-loop ( server quot -- ) [ [ [ accept ] [ addr>> ] bi ] dip From 52297bcfeb0df86b332f907b590a0842709d49ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 04:56:35 -0500 Subject: [PATCH 30/71] Add some simple markup inheritance --- extra/furnace/boilerplate/boilerplate.factor | 13 ++++++++++--- extra/webapps/wiki/wiki-common.xml | 19 ++++++++++++++++++- extra/webapps/wiki/wiki.factor | 9 +++++++-- 3 files changed, 35 insertions(+), 6 deletions(-) diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index 7c5b7a0c81..a976199661 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -1,19 +1,26 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces -html.templates html.templates.chloe +html.forms +html.templates +html.templates.chloe locals http.server http.server.filters furnace ; IN: furnace.boilerplate -TUPLE: boilerplate < filter-responder template ; +TUPLE: boilerplate < filter-responder template init ; -: ( responder -- boilerplate ) f boilerplate boa ; +: ( responder -- boilerplate ) + boilerplate new + swap >>responder + [ ] >>init ; M:: boilerplate call-responder* ( path responder -- ) + begin-form path responder call-next-method + responder init>> call dup content-type>> "text/html" = [ clone [| body | [ diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 4c6d1a5b5c..1d08d3832d 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -28,6 +28,23 @@

- + + + + + + + +
+ +

+ + + +

+ + + +
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 3183b48da9..ebaa60777f 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -78,6 +78,10 @@ M: revision feed-entry-url id>> revision-url ; [ "Front Page" view-url ] >>display ; +: latest-revision ( title -- revision/f ) +
select-tuple + dup [ revision>> select-tuple ] when ; + : ( -- action ) @@ -88,8 +92,8 @@ M: revision feed-entry-url id>> revision-url ; ] >>init [ - "title" value dup
select-tuple [ - revision>> select-tuple from-object + "title" value dup latest-revision [ + from-object { wiki "view" } ] [ edit-url @@ -297,4 +301,5 @@ M: revision feed-entry-url id>> revision-url ; "changes.atom" add-responder "delete" add-responder + [ "sidebar" [ "Sidebar" latest-revision from-object ] nest-form ] >>init { wiki "wiki-common" } >>template ; From 56bb1604f0dd1baba733a6e49def22551022f8a2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 18:29:10 -0500 Subject: [PATCH 31/71] Fix load errors --- extra/html/templates/chloe/chloe-tests.factor | 6 +++--- extra/webapps/counter/counter.factor | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 87ba37ed9e..4048836cfe 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -1,7 +1,7 @@ USING: html.templates html.templates.chloe tools.test io.streams.string kernel sequences ascii boxes -namespaces xml html.components -splitting unicode.categories furnace ; +namespaces xml html.components html.forms +splitting unicode.categories furnace accessors ; IN: html.templates.chloe.tests [ f ] [ f parse-query-attr ] unit-test @@ -160,7 +160,7 @@ TUPLE: person first-name last-name ; [ ] [ begin-form ] unit-test [ ] [ - H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value + H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } >>values "person" set-value ] unit-test [ "
RBaxterUnknown
" ] [ diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index da646fb76f..30c5d403de 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,6 +1,6 @@ USING: math kernel accessors http.server http.server.dispatchers furnace furnace.actions furnace.sessions -html.components html.templates.chloe +html.components html.forms html.templates.chloe fry urls ; IN: webapps.counter From dbe095a84d6b3dbd954aff510116df2ac04c352c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 21:57:41 -0500 Subject: [PATCH 32/71] Fix revisions --- extra/webapps/wiki/wiki.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index ebaa60777f..34bad6db18 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -236,8 +236,8 @@ M: revision feed-entry-url id>> revision-url ; "old-id" "new-id" [ value select-tuple ] bi@ [ - [ [ title>> "title" set-value ] [ "old" set-value ] bi ] - [ "new" set-value ] bi* + [ [ title>> "title" set-value ] [ "old" [ from-object ] nest-form ] bi ] + [ "new" [ from-object ] nest-form ] bi* ] [ [ content>> string-lines ] bi@ diff "diff" set-value ] 2bi From 71d65880e57de7a8e763259c37ef618fccee38cd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 22:49:54 -0500 Subject: [PATCH 33/71] SSL session resumption --- .../unix/sockets/secure/secure-tests.factor | 4 +- extra/io/unix/sockets/secure/secure.factor | 24 ++- extra/openssl/libssl/libssl.factor | 154 ++++++++++++------ extra/openssl/openssl.factor | 32 +++- 4 files changed, 154 insertions(+), 60 deletions(-) diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor index cbda002354..dca8fbbbc7 100644 --- a/extra/io/unix/sockets/secure/secure-tests.factor +++ b/extra/io/unix/sockets/secure/secure-tests.factor @@ -9,7 +9,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ; [ ] [ "port" set ] unit-test -: with-test-context +: with-test-context ( quot -- ) "resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/dh1024.pem" >>dh-file @@ -28,7 +28,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ; ] with-test-context ] "SSL server test" spawn drop ; -: client-test +: client-test ( -- string ) [ "127.0.0.1" "port" get ?promise ascii drop contents ] with-secure-context ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 946e0e7be5..a0acbebb3a 100755 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -118,13 +118,27 @@ M: secure (get-local-address) addrspec>> (get-local-address) ; dup dup handle>> SSL_connect check-connect-response dup [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ; +: resume-session ( ssl-handle ssl-session -- ) + [ [ handle>> ] dip SSL_set_session ssl-error ] + [ drop do-ssl-connect ] + 2bi ; + +: begin-session ( ssl-handle addrspec -- ) + [ drop do-ssl-connect ] + [ [ handle>> SSL_get1_session ] dip save-session ] + 2bi ; + +: secure-connection ( ssl-handle addrspec -- ) + dup get-session [ resume-session ] [ begin-session ] ?if ; + M: secure establish-connection ( client-out remote -- ) - [ addrspec>> establish-connection ] + addrspec>> + [ establish-connection ] [ - drop handle>> - [ [ do-ssl-connect ] with-timeout ] - [ t >>connected drop ] - bi + [ handle>> ] dip + [ [ secure-connection ] curry with-timeout ] + [ drop t >>connected drop ] + 2bi ] 2bi ; M: secure (server) addrspec>> (server) ; diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 3218d67b5c..dced2e5c0c 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -1,12 +1,8 @@ ! Copyright (C) 2007 Elie CHAFTARI +! Portions copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -! -! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC -! -! export LD_LIBRARY_PATH=/opt/local/lib - USING: alien alien.syntax combinators kernel system namespaces -assocs parser sequences words quotations ; +assocs parser sequences words quotations math.bitfields ; IN: openssl.libssl @@ -24,11 +20,47 @@ IN: openssl.libssl : SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1 ; inline : SSL_FILETYPE_PEM X509_FILETYPE_PEM ; inline -: SSL_CTRL_NEED_TMP_RSA 1 ; inline -: SSL_CTRL_SET_TMP_RSA 2 ; inline -: SSL_CTRL_SET_TMP_DH 3 ; inline -: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline -: SSL_CTRL_SET_TMP_DH_CB 5 ; inline +: SSL_CTRL_NEED_TMP_RSA 1 ; inline +: SSL_CTRL_SET_TMP_RSA 2 ; inline +: SSL_CTRL_SET_TMP_DH 3 ; inline +: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline +: SSL_CTRL_SET_TMP_DH_CB 5 ; inline + +: SSL_CTRL_GET_SESSION_REUSED 6 ; inline +: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7 ; inline +: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8 ; inline +: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9 ; inline +: SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 10 ; inline +: SSL_CTRL_GET_FLAGS 11 ; inline +: SSL_CTRL_EXTRA_CHAIN_CERT 12 ; inline + +: SSL_CTRL_SET_MSG_CALLBACK 13 ; inline +: SSL_CTRL_SET_MSG_CALLBACK_ARG 14 ; inline + +: SSL_CTRL_SESS_NUMBER 20 ; inline +: SSL_CTRL_SESS_CONNECT 21 ; inline +: SSL_CTRL_SESS_CONNECT_GOOD 22 ; inline +: SSL_CTRL_SESS_CONNECT_RENEGOTIATE 23 ; inline +: SSL_CTRL_SESS_ACCEPT 24 ; inline +: SSL_CTRL_SESS_ACCEPT_GOOD 25 ; inline +: SSL_CTRL_SESS_ACCEPT_RENEGOTIATE 26 ; inline +: SSL_CTRL_SESS_HIT 27 ; inline +: SSL_CTRL_SESS_CB_HIT 28 ; inline +: SSL_CTRL_SESS_MISSES 29 ; inline +: SSL_CTRL_SESS_TIMEOUTS 30 ; inline +: SSL_CTRL_SESS_CACHE_FULL 31 ; inline +: SSL_CTRL_OPTIONS 32 ; inline +: SSL_CTRL_MODE 33 ; inline + +: SSL_CTRL_GET_READ_AHEAD 40 ; inline +: SSL_CTRL_SET_READ_AHEAD 41 ; inline +: SSL_CTRL_SET_SESS_CACHE_SIZE 42 ; inline +: SSL_CTRL_GET_SESS_CACHE_SIZE 43 ; inline +: SSL_CTRL_SET_SESS_CACHE_MODE 44 ; inline +: SSL_CTRL_GET_SESS_CACHE_MODE 45 ; inline + +: SSL_CTRL_GET_MAX_CERT_LIST 50 ; inline +: SSL_CTRL_SET_MAX_CERT_LIST 51 ; inline : SSL_ERROR_NONE 0 ; inline : SSL_ERROR_SSL 1 ; inline @@ -55,8 +87,9 @@ IN: openssl.libssl } ; TYPEDEF: void* ssl-method -TYPEDEF: void* ssl-ctx -TYPEDEF: void* ssl-pointer +TYPEDEF: void* SSL_CTX* +TYPEDEF: void* SSL_SESSION* +TYPEDEF: void* SSL* LIBRARY: libssl @@ -64,7 +97,7 @@ LIBRARY: libssl ! ssl.h ! =============================================== -FUNCTION: char* SSL_get_version ( ssl-pointer ssl ) ; +FUNCTION: char* SSL_get_version ( SSL* ssl ) ; ! Maps OpenSSL errors to strings FUNCTION: void SSL_load_error_strings ( ) ; @@ -94,42 +127,50 @@ FUNCTION: ssl-method TLSv1_server_method ( ) ; FUNCTION: ssl-method TLSv1_method ( ) ; ! Creates the context -FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ; +FUNCTION: SSL_CTX* SSL_CTX_new ( ssl-method method ) ; ! Load the certificates and private keys into the SSL_CTX -FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx, +FUNCTION: int SSL_CTX_use_certificate_chain_file ( SSL_CTX* ctx, char* file ) ; ! PEM type -FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ; +FUNCTION: SSL* SSL_new ( SSL_CTX* ctx ) ; -FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ; +FUNCTION: int SSL_set_fd ( SSL* ssl, int fd ) ; -FUNCTION: void SSL_set_bio ( ssl-pointer ssl, void* rbio, void* wbio ) ; +FUNCTION: void SSL_set_bio ( SSL* ssl, void* rbio, void* wbio ) ; -FUNCTION: int SSL_get_error ( ssl-pointer ssl, int ret ) ; +FUNCTION: int SSL_set_session ( SSL* to, SSL_SESSION* session ) ; -FUNCTION: void SSL_set_connect_state ( ssl-pointer ssl ) ; +FUNCTION: int SSL_get_error ( SSL* ssl, int ret ) ; -FUNCTION: void SSL_set_accept_state ( ssl-pointer ssl ) ; +FUNCTION: void SSL_set_connect_state ( SSL* ssl ) ; -FUNCTION: int SSL_connect ( ssl-pointer ssl ) ; +FUNCTION: void SSL_set_accept_state ( SSL* ssl ) ; -FUNCTION: int SSL_accept ( ssl-pointer ssl ) ; +FUNCTION: int SSL_connect ( SSL* ssl ) ; -FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ; +FUNCTION: int SSL_accept ( SSL* ssl ) ; -FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ; +FUNCTION: int SSL_write ( SSL* ssl, void* buf, int num ) ; -FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ; +FUNCTION: int SSL_read ( SSL* ssl, void* buf, int num ) ; + +FUNCTION: int SSL_shutdown ( SSL* ssl ) ; : SSL_SENT_SHUTDOWN 1 ; : SSL_RECEIVED_SHUTDOWN 2 ; -FUNCTION: int SSL_get_shutdown ( ssl-pointer ssl ) ; +FUNCTION: int SSL_get_shutdown ( SSL* ssl ) ; -FUNCTION: void SSL_free ( ssl-pointer ssl ) ; +FUNCTION: int SSL_CTX_set_session_id_context ( SSL_CTX* ctx, char* sid_ctx, uint len ) ; -FUNCTION: int SSL_want ( ssl-pointer ssl ) ; +FUNCTION: SSL_SESSION* SSL_get1_session ( SSL* ssl ) ; + +FUNCTION: void SSL_free ( SSL* ssl ) ; + +FUNCTION: void SSL_SESSION_free ( SSL_SESSION* ses ) ; + +FUNCTION: int SSL_want ( SSL* ssl ) ; : SSL_NOTHING 1 ; inline : SSL_WRITING 2 ; inline @@ -140,55 +181,55 @@ FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ; FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ; -FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ; +FUNCTION: void SSL_CTX_free ( SSL_CTX* ctx ) ; FUNCTION: void RAND_seed ( void* buf, int num ) ; -FUNCTION: int SSL_set_cipher_list ( ssl-pointer ssl, char* str ) ; +FUNCTION: int SSL_set_cipher_list ( SSL* ssl, char* str ) ; -FUNCTION: int SSL_use_RSAPrivateKey_file ( ssl-pointer ssl, char* str ) ; +FUNCTION: int SSL_use_RSAPrivateKey_file ( SSL* ssl, char* str ) ; -FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( ssl-ctx ctx, int type ) ; +FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( SSL_CTX* ctx, int type ) ; -FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl, +FUNCTION: int SSL_use_certificate_file ( SSL* ssl, char* str, int type ) ; -FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile, +FUNCTION: int SSL_CTX_load_verify_locations ( SSL_CTX* ctx, char* CAfile, char* CApath ) ; -FUNCTION: int SSL_CTX_set_default_verify_paths ( ssl-ctx ctx ) ; +FUNCTION: int SSL_CTX_set_default_verify_paths ( SSL_CTX* ctx ) ; : SSL_VERIFY_NONE 0 ; inline : SSL_VERIFY_PEER 1 ; inline : SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline : SSL_VERIFY_CLIENT_ONCE 4 ; inline -FUNCTION: void SSL_CTX_set_verify ( ssl-ctx ctx, int mode, void* callback ) ; +FUNCTION: void SSL_CTX_set_verify ( SSL_CTX* ctx, int mode, void* callback ) ; -FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ; +FUNCTION: void SSL_CTX_set_client_CA_list ( SSL_CTX* ctx, SSL* list ) ; -FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ; +FUNCTION: SSL* SSL_load_client_CA_file ( char* file ) ; ! Used to manipulate settings of the SSL_CTX and SSL objects. ! This function should never be called directly -FUNCTION: long SSL_CTX_ctrl ( ssl-ctx ctx, int cmd, long larg, void* parg ) ; +FUNCTION: long SSL_CTX_ctrl ( SSL_CTX* ctx, int cmd, long larg, void* parg ) ; -FUNCTION: void SSL_CTX_set_default_passwd_cb ( ssl-ctx ctx, void* cb ) ; +FUNCTION: void SSL_CTX_set_default_passwd_cb ( SSL_CTX* ctx, void* cb ) ; -FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( ssl-ctx ctx, +FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( SSL_CTX* ctx, void* u ) ; -FUNCTION: int SSL_CTX_use_PrivateKey_file ( ssl-ctx ctx, char* file, +FUNCTION: int SSL_CTX_use_PrivateKey_file ( SSL_CTX* ctx, char* file, int type ) ; -! Sets the maximum depth for the allowed ctx certificate chain verification -FUNCTION: void SSL_CTX_set_verify_depth ( ssl-ctx ctx, int depth ) ; +! Sets the maximum depth for the allowed ctx certificate chain verification +FUNCTION: void SSL_CTX_set_verify_depth ( SSL_CTX* ctx, int depth ) ; ! Sets DH parameters to be used to be dh. ! The key is inherited by all ssl objects created from ctx -FUNCTION: void SSL_CTX_set_tmp_dh_callback ( ssl-ctx ctx, void* dh ) ; +FUNCTION: void SSL_CTX_set_tmp_dh_callback ( SSL_CTX* ctx, void* dh ) ; -FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ; +FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ; FUNCTION: void* BIO_f_ssl ( ) ; @@ -198,6 +239,23 @@ FUNCTION: void* BIO_f_ssl ( ) ; : SSL_CTX_set_tmp_dh ( ctx dh -- n ) >r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ; +: SSL_CTX_set_session_cache_mode ( ctx mode -- n ) + >r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ; + +: SSL_SESS_CACHE_OFF HEX: 0000 ; inline +: SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline +: SSL_SESS_CACHE_SERVER HEX: 0002 ; inline + +: SSL_SESS_CACHE_BOTH ( -- n ) + { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline + +: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080 ; inline +: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100 ; inline +: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 ; inline + +: SSL_SESS_CACHE_NO_INTERNAL ( -- n ) + { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline + ! =============================================== ! x509.h ! =============================================== diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index b2dbda7d2e..6d750bd8e0 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays kernel debugger sequences namespaces math math.order combinators init alien alien.c-types alien.strings libc -continuations destructors debugger inspector splitting -locals unicode.case +continuations destructors debugger inspector splitting assocs +random math.parser locals unicode.case openssl.libcrypto openssl.libssl io.backend io.ports io.files io.encodings.8-bit io.sockets.secure io.timeouts ; @@ -48,7 +48,13 @@ SYMBOL: ssl-initialized? [ f ssl-initialized? set-global ] "openssl" add-init-hook -TUPLE: openssl-context < secure-context aliens ; +TUPLE: openssl-context < secure-context aliens sessions ; + +: set-session-cache ( ctx -- ) + handle>> + [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ] + [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ] + bi ; : load-certificate-chain ( ctx -- ) dup config>> key-file>> [ @@ -133,12 +139,20 @@ M: rsa dispose* handle>> RSA_free ; ] bi SSL_CTX_set_tmp_rsa ssl-error ; +: ( config ctx -- context ) + openssl-context new + swap >>handle + swap >>config + V{ } clone >>aliens + H{ } clone >>sessions ; + M: openssl ( config -- context ) maybe-init-ssl [ dup method>> ssl-method SSL_CTX_new - dup ssl-error f V{ } clone openssl-context boa |dispose + dup ssl-error |dispose { + [ set-session-cache ] [ load-certificate-chain ] [ set-default-password ] [ use-private-key-file ] @@ -152,8 +166,9 @@ M: openssl ( config -- context ) M: openssl-context dispose* [ aliens>> [ free ] each ] + [ sessions>> values [ SSL_SESSION_free ] each ] [ handle>> SSL_CTX_free ] - bi ; + tri ; TUPLE: ssl-handle file handle connected disposed ; @@ -204,4 +219,11 @@ M: openssl check-certificate ( host ssl -- ) 2bi ] [ 2drop ] if ; +: get-session ( addrspec -- session/f ) + current-secure-context sessions>> at + dup expired? [ drop f ] when ; + +: save-session ( session addrspec -- ) + current-secure-context sessions>> set-at ; + openssl secure-socket-backend set-global From 00e97257299fe80e1d8f82a3dc9707c44195dfad Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Jun 2008 23:04:17 -0500 Subject: [PATCH 34/71] Fix load error --- extra/tangle/sandbox/sandbox.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tangle/sandbox/sandbox.factor b/extra/tangle/sandbox/sandbox.factor index b6e110ada5..b44acb7617 100644 --- a/extra/tangle/sandbox/sandbox.factor +++ b/extra/tangle/sandbox/sandbox.factor @@ -12,7 +12,7 @@ IN: tangle.sandbox ] with-tangle ; : new-sandbox ( -- ) - development-mode on + development? on delete-db sandbox-db f [ make-sandbox ] [ ] bi main-responder set ; From a943a237d956b8c1cb051224ad555484384ab4c3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Jun 2008 01:35:06 -0500 Subject: [PATCH 35/71] Fix information leakage --- extra/http/http-tests.factor | 4 ++++ extra/http/http.factor | 14 ++++++++++++-- extra/http/server/server.factor | 25 +++++++++---------------- 3 files changed, 25 insertions(+), 18 deletions(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 88d42d9796..d092e5008f 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -276,3 +276,7 @@ SYMBOL: a [ 4 ] [ a get-global ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test + +! Test cloning +[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test +[ f ] [ <404> dup clone "b" "a" put-cookie drop "a" get-cookie ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 521c18c703..25bf20429d 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -6,7 +6,8 @@ assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present -io io.encodings.iana io.encodings.binary io.encodings.8-bit +io io.encodings io.encodings.iana io.encodings.binary +io.encodings.8-bit unicode.case unicode.categories qualified @@ -298,6 +299,11 @@ body ; latin1 >>content-charset V{ } clone >>cookies ; +M: response clone + call-next-method + [ clone ] change-header + [ clone ] change-cookies ; + : read-response-version ( response -- response ) " \t" read-until [ "Bad response: version" throw ] unless @@ -363,7 +369,11 @@ M: response write-response ( respose -- ) M: response write-full-response ( request response -- ) dup write-response - swap method>> "HEAD" = [ write-response-body ] unless ; + swap method>> "HEAD" = [ + [ content-charset>> encode-output ] + [ write-response-body ] + bi + ] unless ; : get-cookie ( request/response name -- cookie/f ) [ cookies>> ] dip '[ , _ name>> = ] find nip ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index dc66cb1507..f709939e21 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -60,23 +60,16 @@ main-responder global [ <404> or ] change-at swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) - [ write-response ] + [ request get swap write-full-response ] [ - request get method>> "HEAD" = [ drop ] [ - '[ - , - [ content-charset>> encode-output ] - [ write-response-body ] - bi - ] - [ - utf8 [ - development? get - [ http-error. ] [ drop "Response error" rethrow ] if - ] with-encoded-output - ] recover - ] if - ] bi ; + [ \ do-response log-error ] + [ + utf8 [ + development? get + [ http-error. ] [ drop "Response error" write ] if + ] with-encoded-output + ] bi + ] recover ; LOG: httpd-hit NOTICE From 39d8bec7ef41228902ec00e829aa0505ff269528 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Jun 2008 03:34:17 -0500 Subject: [PATCH 36/71] Refactoring furnace.auth --- extra/furnace/auth/auth.factor | 100 ++++- extra/furnace/auth/basic/basic.factor | 44 +- .../furnace/auth/{login => }/boilerplate.xml | 0 .../edit-profile/edit-profile-tests.factor | 4 + .../features/edit-profile/edit-profile.factor | 67 ++++ .../edit-profile}/edit-profile.xml | 0 .../recover-password}/recover-1.xml | 0 .../recover-password}/recover-2.xml | 0 .../recover-password}/recover-3.xml | 0 .../recover-password}/recover-4.xml | 0 .../recover-password-tests.factor | 4 + .../recover-password/recover-password.factor | 123 ++++++ .../registration}/register.xml | 0 .../registration/registration-tests.factor | 4 + .../features/registration/registration.factor | 43 ++ extra/furnace/auth/login/login-tests.factor | 4 +- extra/furnace/auth/login/login.factor | 379 ++---------------- .../furnace/auth/providers/db/db-tests.factor | 5 +- extra/furnace/db/db.factor | 3 +- extra/furnace/sessions/sessions.factor | 9 - extra/furnace/utilities/utilities.factor | 19 + extra/http/client/client-tests.factor | 4 +- extra/http/http-tests.factor | 6 +- extra/http/http.factor | 3 +- extra/webapps/blogs/blogs.factor | 14 +- .../factor-website/factor-website.factor | 11 +- extra/webapps/todo/todo.factor | 3 +- extra/webapps/user-admin/user-admin.factor | 8 +- 28 files changed, 426 insertions(+), 431 deletions(-) rename extra/furnace/auth/{login => }/boilerplate.xml (100%) create mode 100644 extra/furnace/auth/features/edit-profile/edit-profile-tests.factor create mode 100644 extra/furnace/auth/features/edit-profile/edit-profile.factor rename extra/furnace/auth/{login => features/edit-profile}/edit-profile.xml (100%) rename extra/furnace/auth/{login => features/recover-password}/recover-1.xml (100%) rename extra/furnace/auth/{login => features/recover-password}/recover-2.xml (100%) rename extra/furnace/auth/{login => features/recover-password}/recover-3.xml (100%) rename extra/furnace/auth/{login => features/recover-password}/recover-4.xml (100%) create mode 100644 extra/furnace/auth/features/recover-password/recover-password-tests.factor create mode 100644 extra/furnace/auth/features/recover-password/recover-password.factor rename extra/furnace/auth/{login => features/registration}/register.xml (100%) create mode 100644 extra/furnace/auth/features/registration/registration-tests.factor create mode 100644 extra/furnace/auth/features/registration/registration.factor create mode 100644 extra/furnace/utilities/utilities.factor diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index f78cea3835..d10ba48ce5 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -1,11 +1,18 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets +destructors combinators +io.encodings.utf8 io.encodings.string io.binary random +checksums checksums.sha2 +html.forms http.server http.server.filters http.server.dispatchers -furnace.sessions -furnace.auth.providers ; +furnace +furnace.actions +furnace.boilerplate +furnace.auth.providers +furnace.auth.providers.db ; IN: furnace.auth SYMBOL: logged-in-user @@ -20,6 +27,9 @@ M: dispatcher init-user-profile M: filter-responder init-user-profile responder>> init-user-profile ; +: have-capability? ( capability -- ? ) + logged-in-user get capabilities>> member? ; + : profile ( -- assoc ) logged-in-user get profile>> ; : user-changed ( -- ) @@ -41,3 +51,89 @@ SYMBOL: capabilities V{ } clone capabilities set-global : define-capability ( word -- ) capabilities get adjoin ; + +TUPLE: realm < dispatcher name users checksum ; + +GENERIC: login-required* ( realm -- response ) + +GENERIC: logged-in-username ( realm -- username ) + +: login-required ( -- * ) realm get login-required* exit-with ; + +: new-realm ( responder name class -- realm ) + new-dispatcher + swap >>name + swap >>default + users-in-db >>users + sha-256 >>checksum ; inline + +: users ( -- provider ) + realm get users>> ; + +TUPLE: user-saver user ; + +C: user-saver + +M: user-saver dispose + user>> dup changed?>> [ users update-user ] [ drop ] if ; + +: save-user-after ( user -- ) + &dispose drop ; + +: init-user ( realm -- ) + logged-in-username [ + users get-user + [ logged-in-user set ] [ save-user-after ] bi + ] when* ; + +M: realm call-responder* ( path responder -- response ) + dup realm set + dup init-user + call-next-method ; + +: encode-password ( string salt -- bytes ) + [ utf8 encode ] [ 4 >be ] bi* append + realm get checksum>> checksum-bytes ; + +: >>encoded-password ( user string -- user ) + 32 random-bits [ encode-password ] keep + [ >>password ] [ >>salt ] bi* ; inline + +: valid-login? ( password user -- ? ) + [ salt>> encode-password ] [ password>> ] bi = ; + +: check-login ( password username -- user/f ) + users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ; + +TUPLE: protected < filter-responder description capabilities ; + +: ( responder -- protected ) + protected new + swap >>responder ; + +: check-capabilities ( responder user/f -- ? ) + { + { [ dup not ] [ 2drop f ] } + { [ dup deleted>> ] [ 2drop f ] } + [ [ capabilities>> ] bi@ subset? ] + } cond ; + +M: protected call-responder* ( path responder -- response ) + dup protected set + dup logged-in-user get check-capabilities + [ call-next-method ] [ 2drop realm get login-required* ] if ; + +: ( responder -- responder' ) + { realm "boilerplate" } >>template ; + +: password-mismatch ( -- * ) + "passwords do not match" validation-error + validation-failed ; + +: same-password-twice ( -- ) + "new-password" value "verify-password" value = + [ password-mismatch ] unless ; + +: user-exists ( -- * ) + "username taken" validation-error + validation-failed ; diff --git a/extra/furnace/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor index c8d542c219..ae9cbb82c1 100755 --- a/extra/furnace/auth/basic/basic.factor +++ b/extra/furnace/auth/basic/basic.factor @@ -1,41 +1,27 @@ ! Copyright (c) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors quotations assocs kernel splitting -base64 html.elements io combinators sequences -http http.server.filters http.server.responses http.server -furnace.auth.providers furnace.auth.login ; +USING: accessors kernel splitting base64 namespaces +http http.server.responses furnace.auth ; IN: furnace.auth.basic -TUPLE: basic-auth < filter-responder realm provider ; +TUPLE: basic-auth-realm < realm ; -C: basic-auth +C: basic-auth-realm -: authorization-ok? ( provider header -- ? ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. +: parse-basic-auth ( header -- username/f password/f ) dup [ " " split1 swap "Basic" = [ - base64> ":" split1 spin check-login - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; + base64> ":" split1 + ] [ drop f f ] if + ] [ drop f f ] if ; : <401> ( realm -- response ) - 401 "Unauthorized" - "Basic realm=\"" rot "\"" 3append - "WWW-Authenticate" set-header - [ - - "Username or Password is invalid" write - - ] >>body ; + 401 "Invalid username or password" + [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ; -: logged-in? ( request responder -- ? ) - provider>> swap "authorization" header authorization-ok? ; +M: basic-auth-realm login-required* ( realm -- response ) + name>> <401> ; -M: basic-auth call-responder* ( request path responder -- response ) - pick over logged-in? - [ call-next-method ] [ 2nip realm>> <401> ] if ; +M: basic-auth-realm logged-in-username ( realm -- uid ) + request get "authorization" header parse-basic-auth + dup [ over realm get check-login swap and ] [ 2drop f ] if ; diff --git a/extra/furnace/auth/login/boilerplate.xml b/extra/furnace/auth/boilerplate.xml similarity index 100% rename from extra/furnace/auth/login/boilerplate.xml rename to extra/furnace/auth/boilerplate.xml diff --git a/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor b/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor new file mode 100644 index 0000000000..d0fdf22c27 --- /dev/null +++ b/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor @@ -0,0 +1,4 @@ +IN: furnace.auth.features.edit-profile.tests +USING: tools.test furnace.auth.features.edit-profile ; + +\ allow-edit-profile must-infer diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.factor b/extra/furnace/auth/features/edit-profile/edit-profile.factor new file mode 100644 index 0000000000..4edb4ac364 --- /dev/null +++ b/extra/furnace/auth/features/edit-profile/edit-profile.factor @@ -0,0 +1,67 @@ +! Copyright (c) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors namespaces sequences assocs +validators urls +html.forms +http.server.dispatchers +furnace.auth +furnace.asides +furnace.actions ; +IN: furnace.auth.features.edit-profile + +: ( -- action ) + + [ + logged-in-user get + [ username>> "username" set-value ] + [ realname>> "realname" set-value ] + [ email>> "email" set-value ] + tri + ] >>init + + { realm "features/edit-profile/edit-profile" } >>template + + [ + logged-in-user get username>> "username" set-value + + { + { "realname" [ [ v-one-line ] v-optional ] } + { "password" [ ] } + { "new-password" [ [ v-password ] v-optional ] } + { "verify-password" [ [ v-password ] v-optional ] } + { "email" [ [ v-email ] v-optional ] } + } validate-params + + { "password" "new-password" "verify-password" } + [ value empty? not ] contains? [ + "password" value logged-in-user get username>> check-login + [ "incorrect password" validation-error ] unless + + same-password-twice + ] when + ] >>validate + + [ + logged-in-user get + + "new-password" value dup empty? + [ drop ] [ >>encoded-password ] if + + "realname" value >>realname + "email" value >>email + + t >>changed? + + drop + + URL" $login" end-aside + ] >>submit + + + "edit your profile" >>description ; + +: allow-edit-profile ( login -- login ) + "edit-profile" add-responder ; + +: allow-edit-profile? ( -- ? ) + realm get get responders>> "edit-profile" swap key? ; diff --git a/extra/furnace/auth/login/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml similarity index 100% rename from extra/furnace/auth/login/edit-profile.xml rename to extra/furnace/auth/features/edit-profile/edit-profile.xml diff --git a/extra/furnace/auth/login/recover-1.xml b/extra/furnace/auth/features/recover-password/recover-1.xml similarity index 100% rename from extra/furnace/auth/login/recover-1.xml rename to extra/furnace/auth/features/recover-password/recover-1.xml diff --git a/extra/furnace/auth/login/recover-2.xml b/extra/furnace/auth/features/recover-password/recover-2.xml similarity index 100% rename from extra/furnace/auth/login/recover-2.xml rename to extra/furnace/auth/features/recover-password/recover-2.xml diff --git a/extra/furnace/auth/login/recover-3.xml b/extra/furnace/auth/features/recover-password/recover-3.xml similarity index 100% rename from extra/furnace/auth/login/recover-3.xml rename to extra/furnace/auth/features/recover-password/recover-3.xml diff --git a/extra/furnace/auth/login/recover-4.xml b/extra/furnace/auth/features/recover-password/recover-4.xml similarity index 100% rename from extra/furnace/auth/login/recover-4.xml rename to extra/furnace/auth/features/recover-password/recover-4.xml diff --git a/extra/furnace/auth/features/recover-password/recover-password-tests.factor b/extra/furnace/auth/features/recover-password/recover-password-tests.factor new file mode 100644 index 0000000000..b589c52624 --- /dev/null +++ b/extra/furnace/auth/features/recover-password/recover-password-tests.factor @@ -0,0 +1,4 @@ +IN: furnace.auth.features.recover-password +USING: tools.test furnace.auth.features.recover-password ; + +\ allow-password-recovery must-infer diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor new file mode 100644 index 0000000000..1e8d163e99 --- /dev/null +++ b/extra/furnace/auth/features/recover-password/recover-password.factor @@ -0,0 +1,123 @@ +! Copyright (c) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces accessors kernel assocs arrays io.sockets threads +fry urls smtp validators html.forms +http http.server.responses http.server.dispatchers +furnace furnace.actions furnace.auth furnace.auth.providers ; +IN: furnace.auth.features.recover-password + +SYMBOL: lost-password-from + +: current-host ( -- string ) + request get url>> host>> host-name or ; + +: new-password-url ( user -- url ) + "recover-3" + swap [ + [ username>> "username" set ] + [ ticket>> "ticket" set ] + bi + ] H{ } make-assoc + derive-url ; + +: password-email ( user -- email ) + + [ "[ " % current-host % " ] password recovery" % ] "" make >>subject + lost-password-from get >>from + over email>> 1array >>to + [ + "This e-mail was sent by the application server on " % current-host % "\n" % + "because somebody, maybe you, clicked on a ``recover password'' link in the\n" % + "login form, and requested a new password for the user named ``" % + over username>> % "''.\n" % + "\n" % + "If you believe that this request was legitimate, you may click the below link in\n" % + "your browser to set a new password for your account:\n" % + "\n" % + swap new-password-url % + "\n\n" % + "Love,\n" % + "\n" % + " FactorBot\n" % + ] "" make >>body ; + +: send-password-email ( user -- ) + '[ , password-email send-email ] + "E-mail send thread" spawn drop ; + +: ( -- action ) + + { realm "recover-1" } >>template + + [ + { + { "username" [ v-username ] } + { "email" [ v-email ] } + { "captcha" [ v-captcha ] } + } validate-params + ] >>validate + + [ + "email" value "username" value + users issue-ticket [ + send-password-email + ] when* + + URL" $login/recover-2" + ] >>submit ; + +: ( -- action ) + + { realm "recover-2" } >>template ; + +: ( -- action ) + + [ + { + { "username" [ v-username ] } + { "ticket" [ v-required ] } + } validate-params + ] >>init + + { realm "recover-3" } >>template + + [ + { + { "username" [ v-username ] } + { "ticket" [ v-required ] } + { "new-password" [ v-password ] } + { "verify-password" [ v-password ] } + } validate-params + + same-password-twice + ] >>validate + + [ + "ticket" value + "username" value + users claim-ticket [ + "new-password" value >>encoded-password + users update-user + + URL" $login/recover-4" + ] [ + <403> + ] if* + ] >>submit ; + +: ( -- action ) + + { realm "recover-4" } >>template ; + +: allow-password-recovery ( login -- login ) + + "recover-password" add-responder + + "recover-2" add-responder + + "recover-3" add-responder + + "recover-4" add-responder ; + +: allow-password-recovery? ( -- ? ) + realm get responders>> "recover-password" swap key? ; diff --git a/extra/furnace/auth/login/register.xml b/extra/furnace/auth/features/registration/register.xml similarity index 100% rename from extra/furnace/auth/login/register.xml rename to extra/furnace/auth/features/registration/register.xml diff --git a/extra/furnace/auth/features/registration/registration-tests.factor b/extra/furnace/auth/features/registration/registration-tests.factor new file mode 100644 index 0000000000..e770f35586 --- /dev/null +++ b/extra/furnace/auth/features/registration/registration-tests.factor @@ -0,0 +1,4 @@ +IN: furnace.auth.features.registration.tests +USING: tools.test furnace.auth.features.registration ; + +\ allow-registration must-infer diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor new file mode 100644 index 0000000000..3deead4869 --- /dev/null +++ b/extra/furnace/auth/features/registration/registration.factor @@ -0,0 +1,43 @@ +! Copyright (c) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel namespaces validators html.forms urls +http.server.dispatchers +furnace furnace.auth furnace.auth.providers furnace.actions ; +IN: furnace.auth.features.registration + +: ( -- action ) + + { realm "register" } >>template + + [ + { + { "username" [ v-username ] } + { "realname" [ [ v-one-line ] v-optional ] } + { "new-password" [ v-password ] } + { "verify-password" [ v-password ] } + { "email" [ [ v-email ] v-optional ] } + { "captcha" [ v-captcha ] } + } validate-params + + same-password-twice + ] >>validate + + [ + "username" value + "realname" value >>realname + "new-password" value >>encoded-password + "email" value >>email + H{ } clone >>profile + + users new-user [ user-exists ] unless* + + realm get init-user-profile + + URL" $realm" + ] >>submit ; + +: allow-registration ( login -- login ) + "register" add-responder ; + +: allow-registration? ( -- ? ) + realm get responders>> "register" swap key? ; diff --git a/extra/furnace/auth/login/login-tests.factor b/extra/furnace/auth/login/login-tests.factor index 5095ebdb85..64f7bd3b96 100755 --- a/extra/furnace/auth/login/login-tests.factor +++ b/extra/furnace/auth/login/login-tests.factor @@ -1,6 +1,4 @@ IN: furnace.auth.login.tests USING: tools.test furnace.auth.login ; -\ must-infer -\ allow-registration must-infer -\ allow-password-recovery must-infer +\ must-infer diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 80005c452a..1f81c488cc 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -1,103 +1,35 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors quotations assocs kernel splitting -combinators sequences namespaces hashtables sets -fry arrays threads qualified random validators words -io -io.sockets -io.encodings.utf8 -io.encodings.string -io.binary -continuations -destructors -checksums -checksums.sha2 -validators +USING: kernel accessors namespaces validators urls html.forms -html.components -html.elements -urls -http -http.server http.server.dispatchers -http.server.filters -http.server.responses -furnace furnace.auth -furnace.auth.providers -furnace.auth.providers.db -furnace.actions -furnace.asides furnace.flash +furnace.asides +furnace.actions furnace.sessions -furnace.boilerplate ; -QUALIFIED: smtp +furnace.utilities ; IN: furnace.auth.login -: word>string ( word -- string ) - [ word-vocabulary ] [ word-name ] bi ":" swap 3append ; +TUPLE: login-realm < realm ; -: words>strings ( seq -- seq' ) - [ word>string ] map ; +: set-uid ( username -- ) + session get [ (>>uid) ] [ (session-changed) ] bi ; -ERROR: no-such-word name vocab ; - -: string>word ( string -- word ) - ":" split1 swap 2dup lookup dup - [ 2nip ] [ drop no-such-word ] if ; - -: strings>words ( seq -- seq' ) - [ string>word ] map ; - -TUPLE: login < dispatcher users checksum ; - -TUPLE: protected < filter-responder description capabilities ; - -: ( responder -- protected ) - protected new - swap >>responder ; - -: users ( -- provider ) - login get users>> ; - -: encode-password ( string salt -- bytes ) - [ utf8 encode ] [ 4 >be ] bi* append - login get checksum>> checksum-bytes ; - -: >>encoded-password ( user string -- user ) - 32 random-bits [ encode-password ] keep - [ >>password ] [ >>salt ] bi* ; inline - -: valid-login? ( password user -- ? ) - [ salt>> encode-password ] [ password>> ] bi = ; - -: check-login ( password username -- user/f ) - users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ; - -! Destructor -TUPLE: user-saver user ; - -C: user-saver - -M: user-saver dispose - user>> dup changed?>> [ users update-user ] [ drop ] if ; - -: save-user-after ( user -- ) - &dispose drop ; - -! ! ! Login : successful-login ( user -- response ) - username>> set-uid URL" $login" end-aside ; + username>> set-uid URL" $realm" end-aside ; -: login-failed ( -- * ) - "invalid username or password" validation-error - validation-failed ; +: logout ( -- ) f set-uid ; SYMBOL: description SYMBOL: capabilities : flashed-variables { description capabilities } ; +: login-failed ( -- * ) + "invalid username or password" validation-error + validation-failed ; + : ( -- action ) [ @@ -106,7 +38,7 @@ SYMBOL: capabilities capabilities get words>strings "capabilities" set-value ] >>init - { login "login" } >>template + { login-realm "login" } >>template [ { @@ -119,286 +51,21 @@ SYMBOL: capabilities [ successful-login ] [ login-failed ] if* ] >>submit ; -! ! ! New user registration - -: user-exists ( -- * ) - "username taken" validation-error - validation-failed ; - -: password-mismatch ( -- * ) - "passwords do not match" validation-error - validation-failed ; - -: same-password-twice ( -- ) - "new-password" value "verify-password" value = - [ password-mismatch ] unless ; - -: ( -- action ) - - { login "register" } >>template - - [ - { - { "username" [ v-username ] } - { "realname" [ [ v-one-line ] v-optional ] } - { "new-password" [ v-password ] } - { "verify-password" [ v-password ] } - { "email" [ [ v-email ] v-optional ] } - { "captcha" [ v-captcha ] } - } validate-params - - same-password-twice - ] >>validate - - [ - "username" value - "realname" value >>realname - "new-password" value >>encoded-password - "email" value >>email - H{ } clone >>profile - - users new-user [ user-exists ] unless* - - login get init-user-profile - - successful-login - ] >>submit ; - -! ! ! Editing user profile - -: ( -- action ) - - [ - logged-in-user get - [ username>> "username" set-value ] - [ realname>> "realname" set-value ] - [ email>> "email" set-value ] - tri - ] >>init - - { login "edit-profile" } >>template - - [ - uid "username" set-value - - { - { "realname" [ [ v-one-line ] v-optional ] } - { "password" [ ] } - { "new-password" [ [ v-password ] v-optional ] } - { "verify-password" [ [ v-password ] v-optional ] } - { "email" [ [ v-email ] v-optional ] } - } validate-params - - { "password" "new-password" "verify-password" } - [ value empty? not ] contains? [ - "password" value uid check-login - [ "incorrect password" validation-error ] unless - - same-password-twice - ] when - ] >>validate - - [ - logged-in-user get - - "new-password" value dup empty? - [ drop ] [ >>encoded-password ] if - - "realname" value >>realname - "email" value >>email - - t >>changed? - - drop - - URL" $login" end-aside - ] >>submit - - - "edit your profile" >>description ; - -! ! ! Password recovery - -SYMBOL: lost-password-from - -: current-host ( -- string ) - request get url>> host>> host-name or ; - -: new-password-url ( user -- url ) - "recover-3" - 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 - [ - "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 ; - -: ( -- action ) - - { login "recover-1" } >>template - - [ - { - { "username" [ v-username ] } - { "email" [ v-email ] } - { "captcha" [ v-captcha ] } - } validate-params - ] >>validate - - [ - "email" value "username" value - users issue-ticket [ - send-password-email - ] when* - - URL" $login/recover-2" - ] >>submit ; - -: ( -- action ) - - { login "recover-2" } >>template ; - -: ( -- action ) - - [ - { - { "username" [ v-username ] } - { "ticket" [ v-required ] } - } validate-params - ] >>init - - { login "recover-3" } >>template - - [ - { - { "username" [ v-username ] } - { "ticket" [ v-required ] } - { "new-password" [ v-password ] } - { "verify-password" [ v-password ] } - } validate-params - - same-password-twice - ] >>validate - - [ - "ticket" value - "username" value - users claim-ticket [ - "new-password" value >>encoded-password - users update-user - - URL" $login/recover-4" - ] [ - <403> - ] if* - ] >>submit ; - -: ( -- action ) - - { login "recover-4" } >>template ; - -! ! ! Logout : ( -- action ) - [ - f set-uid - URL" $login" end-aside - ] >>submit ; + [ logout URL" $login-realm" end-aside ] >>submit ; -! ! ! Authentication logic -: show-login-page ( -- response ) +M: login-realm login-required* + drop begin-aside protected get description>> description set protected get capabilities>> capabilities set URL" $login/login" flashed-variables ; -: login-required ( -- * ) - show-login-page exit-with ; +M: login-realm logged-in-username + drop session get uid>> ; -: have-capability? ( capability -- ? ) - logged-in-user get capabilities>> member? ; - -: check-capabilities ( responder user/f -- ? ) - dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ; - -M: protected call-responder* ( path responder -- response ) - dup protected set - dup logged-in-user get check-capabilities - [ call-next-method ] [ 2drop show-login-page ] if ; - -: init-user ( -- ) - uid [ - users get-user - [ logged-in-user set ] - [ save-user-after ] bi - ] when* ; - -M: login call-responder* ( path responder -- response ) - dup login set - init-user - call-next-method ; - -: ( responder -- responder' ) - - { login "boilerplate" } >>template ; - -: ( responder -- auth ) - login new-dispatcher - swap >>default - "login" add-responder - "logout" add-responder - users-in-db >>users - sha-256 >>checksum ; - -! ! ! Configuration - -: allow-edit-profile ( login -- login ) - "edit-profile" add-responder ; - -: allow-registration ( login -- login ) - - "register" add-responder ; - -: allow-password-recovery ( login -- login ) - - "recover-password" add-responder - - "recover-2" add-responder - - "recover-3" add-responder - - "recover-4" add-responder ; - -: allow-edit-profile? ( -- ? ) - login get responders>> "edit-profile" swap key? ; - -: allow-registration? ( -- ? ) - login get responders>> "register" swap key? ; - -: allow-password-recovery? ( -- ? ) - login get responders>> "recover-password" swap key? ; +: ( responder name -- auth ) + login-realm new-realm + "login" add-responder + "logout" add-responder ; diff --git a/extra/furnace/auth/providers/db/db-tests.factor b/extra/furnace/auth/providers/db/db-tests.factor index e5914c7ab3..fac5c23e4a 100755 --- a/extra/furnace/auth/providers/db/db-tests.factor +++ b/extra/furnace/auth/providers/db/db-tests.factor @@ -1,14 +1,13 @@ IN: furnace.auth.providers.db.tests USING: furnace.actions +furnace.auth furnace.auth.login furnace.auth.providers furnace.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations io.files accessors kernel ; - - users-in-db >>users -login set + "test" realm set [ "auth-test.db" temp-file delete-file ] ignore-errors diff --git a/extra/furnace/db/db.factor b/extra/furnace/db/db.factor index 8487b4b3fc..b4a4386015 100755 --- a/extra/furnace/db/db.factor +++ b/extra/furnace/db/db.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors continuations namespaces destructors -db db.pools io.pools http.server http.server.filters -furnace.sessions ; +db db.pools io.pools http.server http.server.filters ; IN: furnace.db TUPLE: db-persistence < filter-responder pool ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 4be7403e39..fe8053fc9c 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -57,12 +57,6 @@ TUPLE: sessions < server-state-manager domain verify? ; [ namespace>> swap change-at ] keep (session-changed) ; inline -: uid ( -- uid ) - session get uid>> ; - -: set-uid ( uid -- ) - session get [ (>>uid) ] [ (session-changed) ] bi ; - : init-session ( session -- ) session [ sessions get init-session* ] with-variable ; @@ -147,6 +141,3 @@ M: sessions call-responder* ( path responder -- response ) sessions set request-session [ begin-session ] unless* existing-session put-session-cookie ; - -: logout-all-sessions ( uid -- ) - session new swap >>uid delete-tuples ; diff --git a/extra/furnace/utilities/utilities.factor b/extra/furnace/utilities/utilities.factor new file mode 100644 index 0000000000..20c05d459f --- /dev/null +++ b/extra/furnace/utilities/utilities.factor @@ -0,0 +1,19 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: words kernel sequences splitting ; +IN: furnace.utilities + +: word>string ( word -- string ) + [ word-vocabulary ] [ word-name ] bi ":" swap 3append ; + +: words>strings ( seq -- seq' ) + [ word>string ] map ; + +ERROR: no-such-word name vocab ; + +: string>word ( string -- word ) + ":" split1 swap 2dup lookup dup + [ 2nip ] [ drop no-such-word ] if ; + +: strings>words ( seq -- seq' ) + [ string>word ] map ; diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index daf4ad88d3..28a605174a 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -14,7 +14,7 @@ tuple-syntax namespaces urls ; method: "GET" version: "1.1" cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } + header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } ] [ "http://www.apple.com/index.html" @@ -27,7 +27,7 @@ tuple-syntax namespaces urls ; method: "GET" version: "1.1" cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } + header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } ] [ "https://www.amazon.com/index.html" diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index d092e5008f..73d26aa327 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -122,7 +122,7 @@ read-response-test-1' 1array [ ! Live-fire exercise USING: http.server http.server.static furnace.sessions furnace.alloy -furnace.actions furnace.auth.login furnace.db http.client +furnace.actions furnace.auth furnace.auth.login furnace.db http.client io.server io.files io io.encodings.ascii accessors namespaces threads http.server.responses http.server.redirection @@ -176,7 +176,7 @@ test-db [ [ - + "Test" "" add-responder add-quit-action @@ -206,7 +206,7 @@ test-db [ [ [ [ "Hi" write ] "text/plain" ] >>display - + "Test" "" add-responder add-quit-action diff --git a/extra/http/http.factor b/extra/http/http.factor index 25bf20429d..d2a0b0f922 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -147,7 +147,7 @@ cookies ; H{ } clone >>header V{ } clone >>cookies "close" "connection" set-header - "Factor http.client vocabulary" "user-agent" set-header ; + "Factor http.client" "user-agent" set-header ; : read-method ( request -- request ) " " read-until [ "Bad request: method" throw ] unless @@ -296,6 +296,7 @@ body ; H{ } clone >>header "close" "connection" set-header now timestamp>http-string "date" set-header + "Factor http.server" "server" set-header latin1 >>content-charset V{ } clone >>cookies ; diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 760951eec6..aa1aa5edc7 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sorting math.order math.parser -urls validators db db.types db.tuples calendar present +urls validators db db.types db.tuples calendar present namespaces html.forms html.components http.server.dispatchers @@ -10,7 +10,6 @@ furnace.actions furnace.auth furnace.auth.login furnace.boilerplate -furnace.sessions furnace.syndication ; IN: webapps.blogs @@ -160,13 +159,13 @@ M: comment entity-url [ validate-post - uid "author" set-value + logged-in-user get username>> "author" set-value ] >>validate [ f dup { "title" "content" } to-object - uid >>author + logged-in-user get username>> >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit @@ -177,7 +176,8 @@ M: comment entity-url "make a new blog post" >>description ; : authorize-author ( author -- ) - uid = can-administer-blogs? have-capability? or + logged-in-user get username>> = + can-administer-blogs? have-capability? or [ login-required ] unless ; : do-post-action ( -- ) @@ -253,13 +253,13 @@ M: comment entity-url [ validate-comment - uid "author" set-value + logged-in-user get username>> "author" set-value ] >>validate [ "parent" value f "content" value >>content - uid >>author + logged-in-user get username>> >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 04fc0487b8..c0bd856d5d 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -7,12 +7,11 @@ logging.insomniac http.server http.server.dispatchers furnace.alloy -furnace.db -furnace.asides -furnace.flash -furnace.sessions furnace.auth.login furnace.auth.providers.db +furnace.auth.features.edit-profile +furnace.auth.features.recover-password +furnace.auth.features.registration furnace.boilerplate webapps.blogs webapps.pastebin @@ -50,8 +49,8 @@ TUPLE: factor-website < dispatcher ; "wiki" add-responder "wee-url" add-responder "user-admin" add-responder - - users-in-db >>users + "Factor website" + "Factor website" >>name allow-registration allow-password-recovery allow-edit-profile diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index dba10184f4..4b1b59e80f 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -8,7 +8,6 @@ html.templates.chloe http.server http.server.dispatchers furnace -furnace.sessions furnace.boilerplate furnace.auth furnace.actions @@ -32,7 +31,7 @@ todo "TODO" : ( id -- todo ) todo new swap >>id - uid >>uid ; + logged-in-user get username>> >>uid ; : ( -- action ) diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 5859d616ee..8c7b1b21c9 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -11,8 +11,8 @@ furnace.auth.providers furnace.auth.providers.db furnace.auth.login furnace.auth -furnace.sessions furnace.actions +furnace.utilities http.server http.server.dispatchers ; IN: webapps.user-admin @@ -138,11 +138,7 @@ TUPLE: user-admin < dispatcher ; [ validate-username - - [ select-tuple 1 >>deleted update-tuple ] - [ logout-all-sessions ] - bi - + select-tuple 1 >>deleted update-tuple URL" $user-admin" ] >>submit ; From 65b8e375df14cf33eb8563e71861ed1001280ee1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Jun 2008 03:34:23 -0500 Subject: [PATCH 37/71] Documentation fix --- core/inference/inference-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 5900e5a844..7d43187f54 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -92,7 +92,7 @@ ARTICLE: "inference-errors" "Inference errors" { $subsection missing-effect } ; ARTICLE: "inference" "Stack effect inference" -"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." +"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." $nl "The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:" { $subsection infer. } From 73105cc043b425ce92ee283cb65a60fa4579bd05 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Jun 2008 03:46:54 -0500 Subject: [PATCH 38/71] Debugging furnace.auth refactoring --- extra/furnace/auth/auth.factor | 4 +++- .../auth/features/edit-profile/edit-profile.factor | 2 +- .../auth/features/edit-profile/edit-profile.xml | 2 +- extra/furnace/auth/login/login.factor | 12 ++++++------ extra/furnace/auth/login/login.xml | 4 ++-- extra/furnace/furnace.factor | 2 +- extra/webapps/blogs/blogs-common.xml | 8 ++++---- extra/webapps/pastebin/pastebin-common.xml | 8 ++++---- extra/webapps/planet/planet-common.xml | 8 ++++---- extra/webapps/todo/todo.xml | 6 +++--- extra/webapps/user-admin/user-admin.xml | 6 +++--- extra/webapps/wiki/wiki-common.xml | 8 ++++---- 12 files changed, 36 insertions(+), 34 deletions(-) diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index d10ba48ce5..9bb7ea105e 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -17,6 +17,8 @@ IN: furnace.auth SYMBOL: logged-in-user +: logged-in? ( -- ? ) logged-in-user get >boolean ; + GENERIC: init-user-profile ( responder -- ) M: object init-user-profile drop ; @@ -114,7 +116,7 @@ TUPLE: protected < filter-responder description capabilities ; : check-capabilities ( responder user/f -- ? ) { { [ dup not ] [ 2drop f ] } - { [ dup deleted>> ] [ 2drop f ] } + { [ dup deleted>> 1 = ] [ 2drop f ] } [ [ capabilities>> ] bi@ subset? ] } cond ; diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.factor b/extra/furnace/auth/features/edit-profile/edit-profile.factor index 4edb4ac364..e03fca99a5 100644 --- a/extra/furnace/auth/features/edit-profile/edit-profile.factor +++ b/extra/furnace/auth/features/edit-profile/edit-profile.factor @@ -64,4 +64,4 @@ IN: furnace.auth.features.edit-profile "edit-profile" add-responder ; : allow-edit-profile? ( -- ? ) - realm get get responders>> "edit-profile" swap key? ; + realm get responders>> "edit-profile" swap key? ; diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml index 6beaf5de6d..011cc2bdf8 100644 --- a/extra/furnace/auth/features/edit-profile/edit-profile.xml +++ b/extra/furnace/auth/features/edit-profile/edit-profile.xml @@ -4,7 +4,7 @@ Edit Profile - + diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 1f81c488cc..6a59c01c63 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -13,13 +13,16 @@ IN: furnace.auth.login TUPLE: login-realm < realm ; +M: login-realm logged-in-username + drop session get uid>> ; + : set-uid ( username -- ) session get [ (>>uid) ] [ (session-changed) ] bi ; : successful-login ( user -- response ) username>> set-uid URL" $realm" end-aside ; -: logout ( -- ) f set-uid ; +: logout ( -- ) f set-uid URL" $realm" end-aside ; SYMBOL: description SYMBOL: capabilities @@ -53,17 +56,14 @@ SYMBOL: capabilities : ( -- action ) - [ logout URL" $login-realm" end-aside ] >>submit ; + [ logout ] >>submit ; M: login-realm login-required* drop begin-aside protected get description>> description set protected get capabilities>> capabilities set - URL" $login/login" flashed-variables ; - -M: login-realm logged-in-username - drop session get uid>> ; + URL" $realm/login" flashed-variables ; : ( responder name -- auth ) login-realm new-realm diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml index a7ac92bf44..81f9520e76 100644 --- a/extra/furnace/auth/login/login.xml +++ b/extra/furnace/auth/login/login.xml @@ -43,11 +43,11 @@

- + Register | - + Recover Password

diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index e9d1b29da8..6b47bc681b 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -31,7 +31,7 @@ IN: furnace : base-path ( string -- pair ) dup responder-nesting get - [ second class word-name = ] with find nip + [ second class superclasses [ word-name = ] with contains? ] with find nip [ first ] [ "No such responder: " swap append throw ] ?if ; : resolve-base-path ( string -- string' ) diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml index 965f059abd..e809c0e7f5 100644 --- a/extra/webapps/blogs/blogs-common.xml +++ b/extra/webapps/blogs/blogs-common.xml @@ -12,13 +12,13 @@ | My Posts | New Post - + - - | Edit Profile + + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index 47f7666b22..b95f3f7b64 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -11,13 +11,13 @@ Pastes | New Paste - + - - | Edit Profile + + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index 34ee73da67..6c0affd17f 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -9,12 +9,12 @@ | Atom Feed | Admin - - - | Edit Profile + + + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index e087fbfcfc..f7500cdad2 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -8,11 +8,11 @@ List Items | Add Item - - | Edit Profile + + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml index 9cb9ef0a0a..2141fdc1d9 100644 --- a/extra/webapps/user-admin/user-admin.xml +++ b/extra/webapps/user-admin/user-admin.xml @@ -6,11 +6,11 @@ List Users | Add User - - | Edit Profile + + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 1d08d3832d..0abd36a7cd 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -14,13 +14,13 @@ | All Articles | Recent Changes - + - - | Edit Profile + + | Edit Profile - | Logout + | Logout From c5a96c093b1a628300a669dc2cc0cfad02b34e42 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Jun 2008 05:16:21 -0500 Subject: [PATCH 39/71] Clean up base64 add add more tets --- extra/base64/base64-tests.factor | 20 +++++++++++++++----- extra/base64/base64.factor | 27 ++++++++++++--------------- 2 files changed, 27 insertions(+), 20 deletions(-) diff --git a/extra/base64/base64-tests.factor b/extra/base64/base64-tests.factor index d867351f8b..86c58af505 100644 --- a/extra/base64/base64-tests.factor +++ b/extra/base64/base64-tests.factor @@ -1,8 +1,18 @@ USING: kernel tools.test base64 strings ; -[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> +[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string ] unit-test -[ "" ] [ "" >base64 base64> ] unit-test -[ "a" ] [ "a" >base64 base64> ] unit-test -[ "ab" ] [ "ab" >base64 base64> ] unit-test -[ "abc" ] [ "abc" >base64 base64> ] unit-test +[ "" ] [ "" >base64 base64> >string ] unit-test +[ "a" ] [ "a" >base64 base64> >string ] unit-test +[ "ab" ] [ "ab" >base64 base64> >string ] unit-test +[ "abc" ] [ "abc" >base64 base64> >string ] unit-test + +! From http://en.wikipedia.org/wiki/Base64 +[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ] +[ + "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure." + >base64 >string +] unit-test + +\ >base64 must-infer +\ base64> must-infer diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor index 600a8f4c3d..d48abc2014 100644 --- a/extra/base64/base64.factor +++ b/extra/base64/base64.factor @@ -1,11 +1,10 @@ -USING: kernel math sequences namespaces io.binary splitting -grouping strings hashtables ; +USING: kernel math sequences io.binary splitting grouping ; IN: base64 r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; + >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline : ch>base64 ( ch -- ch ) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; @@ -20,28 +19,26 @@ IN: base64 } nth ; : encode3 ( seq -- seq ) - be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ; + be> 4 [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ; : decode4 ( str -- str ) - [ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ; + 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ; : >base64-rem ( str -- str ) - [ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ; + [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ; PRIVATE> : >base64 ( seq -- base64 ) #! cut string into two pieces, convert 3 bytes at a time #! pad string with = when not enough bits - dup length dup 3 mod - cut swap - [ - 3 [ encode3 % ] each - dup empty? [ drop ] [ >base64-rem % ] if - ] "" make ; + dup length dup 3 mod - cut + [ 3 [ encode3 ] map concat ] + [ dup empty? [ drop "" ] [ >base64-rem ] if ] + bi* append ; : base64> ( base64 -- str ) #! input length must be a multiple of 4 - [ - [ 4 [ decode4 % ] each ] keep [ CHAR: = = not ] count-end - ] SBUF" " make swap [ dup pop* ] times >string ; - + [ 4 [ decode4 ] map concat ] + [ [ CHAR: = = not ] count-end ] + bi head* ; From e47e7ec30c1b980a13118df8b0919476ca34680a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Jun 2008 05:16:51 -0500 Subject: [PATCH 40/71] Login authentication is now stored outside of the session, allowing multiple independent login realms per site --- extra/furnace/alloy/alloy.factor | 5 +- extra/furnace/auth/auth-tests.factor | 6 ++ extra/furnace/auth/auth.factor | 9 +-- extra/furnace/auth/basic/basic.factor | 10 ++-- .../features/registration/registration.factor | 2 +- extra/furnace/auth/login/login.factor | 56 +++++++++++++++---- .../furnace/auth/login/permits/permits.factor | 30 ++++++++++ .../auth/providers/assoc/assoc-tests.factor | 6 +- extra/furnace/furnace.factor | 13 +++++ extra/furnace/sessions/sessions.factor | 24 ++------ extra/http/http.factor | 12 +++- extra/http/server/static/static.factor | 2 +- extra/webapps/wiki/wiki.factor | 7 ++- 13 files changed, 131 insertions(+), 51 deletions(-) create mode 100644 extra/furnace/auth/auth-tests.factor create mode 100644 extra/furnace/auth/login/permits/permits.factor diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor index 14ffbaba9d..28c34e6715 100644 --- a/extra/furnace/alloy/alloy.factor +++ b/extra/furnace/alloy/alloy.factor @@ -7,7 +7,8 @@ furnace.flash furnace.sessions furnace.referrer furnace.db -furnace.auth.providers ; +furnace.auth.providers +furnace.auth.login.permits ; IN: furnace.alloy : ( responder db params -- responder' ) @@ -19,7 +20,7 @@ IN: furnace.alloy ] call ; -: state-classes { session flash-scope aside } ; inline +: state-classes { session flash-scope aside permit } ; inline : init-furnace-tables ( -- ) state-classes ensure-tables diff --git a/extra/furnace/auth/auth-tests.factor b/extra/furnace/auth/auth-tests.factor new file mode 100644 index 0000000000..220a8cd04c --- /dev/null +++ b/extra/furnace/auth/auth-tests.factor @@ -0,0 +1,6 @@ +USING: furnace.auth tools.test ; +IN: furnace.auth.tests + +\ logged-in-username must-infer +\ must-infer +\ new-realm must-infer diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index 9bb7ea105e..d9f517aaf4 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -82,15 +82,12 @@ M: user-saver dispose : save-user-after ( user -- ) &dispose drop ; -: init-user ( realm -- ) - logged-in-username [ - users get-user - [ logged-in-user set ] [ save-user-after ] bi - ] when* ; +: init-user ( user -- ) + [ [ logged-in-user set ] [ save-user-after ] bi ] when* ; M: realm call-responder* ( path responder -- response ) dup realm set - dup init-user + dup logged-in-username dup [ users get-user ] when init-user call-next-method ; : encode-password ( string salt -- bytes ) diff --git a/extra/furnace/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor index ae9cbb82c1..e478f70dcc 100755 --- a/extra/furnace/auth/basic/basic.factor +++ b/extra/furnace/auth/basic/basic.factor @@ -1,17 +1,18 @@ ! Copyright (c) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel splitting base64 namespaces +USING: accessors kernel splitting base64 namespaces strings http http.server.responses furnace.auth ; IN: furnace.auth.basic TUPLE: basic-auth-realm < realm ; -C: basic-auth-realm +: ( responder name -- realm ) + basic-auth-realm new-realm ; : parse-basic-auth ( header -- username/f password/f ) dup [ " " split1 swap "Basic" = [ - base64> ":" split1 + base64> >string ":" split1 ] [ drop f f ] if ] [ drop f f ] if ; @@ -23,5 +24,6 @@ M: basic-auth-realm login-required* ( realm -- response ) name>> <401> ; M: basic-auth-realm logged-in-username ( realm -- uid ) + drop request get "authorization" header parse-basic-auth - dup [ over realm get check-login swap and ] [ 2drop f ] if ; + dup [ over check-login swap and ] [ 2drop f ] if ; diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor index 3deead4869..2bc7688b10 100644 --- a/extra/furnace/auth/features/registration/registration.factor +++ b/extra/furnace/auth/features/registration/registration.factor @@ -7,7 +7,7 @@ IN: furnace.auth.features.registration : ( -- action ) - { realm "register" } >>template + { realm "features/registration/register" } >>template [ { diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 6a59c01c63..e2b208de3a 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -1,28 +1,57 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces validators urls -html.forms -http.server.dispatchers +USING: kernel accessors namespaces sequences math.parser +calendar validators urls html.forms +http http.server http.server.dispatchers +furnace furnace.auth furnace.flash furnace.asides furnace.actions furnace.sessions -furnace.utilities ; +furnace.utilities +furnace.auth.login.permits ; IN: furnace.auth.login -TUPLE: login-realm < realm ; +SYMBOL: permit-id + +: permit-id-key ( realm -- string ) + [ >hex 2 CHAR: 0 pad-left ] { } map-as concat + "__p_" prepend ; + +: client-permit-id ( realm -- id/f ) + permit-id-key client-state dup [ string>number ] when ; + +TUPLE: login-realm < realm timeout domain ; + +M: login-realm call-responder* + [ name>> client-permit-id permit-id set ] + [ call-next-method ] + bi ; M: login-realm logged-in-username - drop session get uid>> ; + drop permit-id get dup [ get-permit-uid ] when ; -: set-uid ( username -- ) - session get [ (>>uid) ] [ (session-changed) ] bi ; +M: login-realm modify-form ( responder -- ) + drop permit-id get realm get name>> permit-id-key hidden-form-field ; + +: ( -- cookie ) + permit-id get realm get name>> permit-id-key + "$login-realm" resolve-base-path >>path + realm get timeout>> from-now >>expires + realm get domain>> >>domain ; + +: put-permit-cookie ( response -- response' ) + put-cookie ; : successful-login ( user -- response ) - username>> set-uid URL" $realm" end-aside ; + [ username>> make-permit permit-id set ] [ init-user ] bi + URL" $realm" end-aside + put-permit-cookie ; -: logout ( -- ) f set-uid URL" $realm" end-aside ; +: logout ( -- ) + permit-id get [ delete-permit ] when* + URL" $realm" end-aside ; SYMBOL: description SYMBOL: capabilities @@ -56,7 +85,9 @@ SYMBOL: capabilities : ( -- action ) - [ logout ] >>submit ; + [ logout ] >>submit + + "logout" >>description ; M: login-realm login-required* drop @@ -68,4 +99,5 @@ M: login-realm login-required* : ( responder name -- auth ) login-realm new-realm "login" add-responder - "logout" add-responder ; + "logout" add-responder + 20 minutes >>timeout ; diff --git a/extra/furnace/auth/login/permits/permits.factor b/extra/furnace/auth/login/permits/permits.factor new file mode 100644 index 0000000000..49cf98e0e3 --- /dev/null +++ b/extra/furnace/auth/login/permits/permits.factor @@ -0,0 +1,30 @@ +USING: accessors namespaces combinators.lib kernel +db.tuples db.types +furnace.auth furnace.sessions furnace.cache ; +IN: furnace.auth.login.permits + +TUPLE: permit < server-state session uid ; + +permit "PERMITS" { + { "session" "SESSION" BIG-INTEGER +not-null+ } + { "uid" "UID" { VARCHAR 255 } +not-null+ } +} define-persistent + +: touch-permit ( permit -- ) + realm get touch-state ; + +: get-permit-uid ( id -- uid ) + permit get-state { + [ ] + [ session>> session get id>> = ] + [ [ touch-permit ] [ uid>> ] bi ] + } 1&& ; + +: make-permit ( uid -- id ) + permit new + swap >>uid + session get id>> >>session + [ touch-permit ] [ insert-tuple ] [ id>> ] tri ; + +: delete-permit ( id -- ) + permit new-server-state delete-tuples ; diff --git a/extra/furnace/auth/providers/assoc/assoc-tests.factor b/extra/furnace/auth/providers/assoc/assoc-tests.factor index 8f9eeaa7a5..8fe1dd4dd4 100755 --- a/extra/furnace/auth/providers/assoc/assoc-tests.factor +++ b/extra/furnace/auth/providers/assoc/assoc-tests.factor @@ -1,11 +1,11 @@ IN: furnace.auth.providers.assoc.tests -USING: furnace.actions furnace.auth.providers +USING: furnace.actions furnace.auth furnace.auth.providers furnace.auth.providers.assoc furnace.auth.login tools.test namespaces accessors kernel ; - + "Test" >>users -login set +realm set [ t ] [ "slava" diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 6b47bc681b..521f8a3bc1 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -96,6 +96,19 @@ M: object modify-form drop ; request get url>> [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ; +: cookie-client-state ( key request -- value/f ) + swap get-cookie dup [ value>> ] when ; + +: post-client-state ( key request -- value/f ) + request-params at ; + +: client-state ( key -- value/f ) + request get dup method>> { + { "GET" [ cookie-client-state ] } + { "HEAD" [ cookie-client-state ] } + { "POST" [ post-client-state ] } + } case ; + SYMBOL: exit-continuation : exit-with ( value -- ) diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index fe8053fc9c..bb0a844269 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -98,20 +98,6 @@ M: session-saver dispose : session-id-key "__s" ; -: cookie-session-id ( request -- id/f ) - session-id-key get-cookie - dup [ value>> string>number ] when ; - -: post-session-id ( request -- id/f ) - session-id-key swap request-params at string>number ; - -: request-session-id ( -- id/f ) - request get dup method>> { - { "GET" [ cookie-session-id ] } - { "HEAD" [ cookie-session-id ] } - { "POST" [ post-session-id ] } - } case ; - : verify-session ( session -- session ) sessions get verify?>> [ dup [ @@ -123,16 +109,18 @@ M: session-saver dispose ] when ; : request-session ( -- session/f ) - request-session-id get-session verify-session ; + session-id-key + client-state dup [ string>number ] when + get-session verify-session ; -: ( id -- cookie ) - session-id-key +: ( -- cookie ) + session get id>> session-id-key "$sessions" resolve-base-path >>path sessions get timeout>> from-now >>expires sessions get domain>> >>domain ; : put-session-cookie ( response -- response' ) - session get id>> number>string put-cookie ; + put-cookie ; M: sessions modify-form ( responder -- ) drop session get id>> session-id-key hidden-form-field ; diff --git a/extra/http/http.factor b/extra/http/http.factor index d2a0b0f922..025e2c8441 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -99,23 +99,29 @@ TUPLE: cookie name value path domain expires max-age http-only ; drop ] { } make ; +: check-cookie-string ( string -- string' ) + dup "=;'\"" intersect empty? + [ "Bad cookie name or value" throw ] unless ; + : (unparse-cookie) ( key value -- ) { { f [ drop ] } - { t [ , ] } + { t [ check-cookie-string , ] } [ { { [ dup timestamp? ] [ timestamp>cookie-string ] } { [ dup duration? ] [ dt>seconds number>string ] } + { [ dup real? ] [ number>string ] } [ ] } cond - "=" swap 3append , + check-cookie-string "=" swap check-cookie-string 3append , ] } case ; : unparse-cookie ( cookie -- strings ) [ - dup name>> >lower over value>> (unparse-cookie) + dup name>> check-cookie-string >lower + over value>> (unparse-cookie) "path" over path>> (unparse-cookie) "domain" over domain>> (unparse-cookie) "expires" over expires>> (unparse-cookie) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 9d76c82e4a..83fcf6f4a9 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -82,7 +82,7 @@ TUPLE: file-responder root hook special allow-listings ; "index.html" append-path dup exists? [ drop f ] unless ; : serve-directory ( filename -- response ) - request get path>> "/" tail? [ + request get url>> path>> "/" tail? [ dup find-index [ serve-file ] [ list-directory ] ?if ] [ diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 34bad6db18..13c445b0a8 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -284,6 +284,11 @@ M: revision feed-entry-url id>> revision-url ; { wiki "page-common" } >>template ; +: init-sidebar ( -- ) + "Sidebar" latest-revision [ + "sidebar" [ from-object ] nest-form + ] when* ; + : ( -- dispatcher ) wiki new-dispatcher "" add-responder @@ -301,5 +306,5 @@ M: revision feed-entry-url id>> revision-url ; "changes.atom" add-responder "delete" add-responder - [ "sidebar" [ "Sidebar" latest-revision from-object ] nest-form ] >>init + [ init-sidebar ] >>init { wiki "wiki-common" } >>template ; From 12b79b287ff23805a089dfe3aca723a1982ebeb5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Jun 2008 05:17:26 -0500 Subject: [PATCH 41/71] Remove unused slot --- extra/furnace/sessions/sessions.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index bb0a844269..863b8f87cb 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -9,14 +9,13 @@ html.elements furnace furnace.cache ; IN: furnace.sessions -TUPLE: session < server-state uid namespace user-agent client changed? ; +TUPLE: session < server-state namespace user-agent client changed? ; : ( id -- session ) session new-server-state ; session "SESSIONS" { - { "uid" "UID" { VARCHAR 255 } } { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ } { "user-agent" "USER_AGENT" TEXT +not-null+ } { "client" "CLIENT" TEXT +not-null+ } From 285c34696f85b8d2840b9399c9ba7801e248a490 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 16 Jun 2008 16:28:49 -0500 Subject: [PATCH 42/71] dns: minor addition --- extra/dns/dns.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 48380a0d57..214b45ce0c 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -424,6 +424,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED } 2cleave message boa ; +: ba->message ( ba -- message ) parse-message ; + +: with-message-bytes ( ba quot -- ) >r ba->message r> call message->ba ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : send-receive-udp ( ba server -- ba ) From e60f25fe2b01ed56e42a1ae40bcb479cd6423084 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 16 Jun 2008 16:29:11 -0500 Subject: [PATCH 43/71] dns.util: packet abstraction --- extra/dns/util/util.factor | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 5933216a3c..35af74b92a 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -16,4 +16,15 @@ MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: longer? ( seq seq -- ? ) [ length ] bi@ > ; \ No newline at end of file +: longer? ( seq seq -- ? ) [ length ] bi@ > ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: io.sockets accessors ; + +TUPLE: packet data addr socket ; + +: receive-packet ( socket -- packet ) [ receive ] keep packet boa ; + +: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ; + From aa1708d0b586d29b1500a2ea24f0770b91993119 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 16 Jun 2008 16:29:49 -0500 Subject: [PATCH 44/71] dns.server: new networking code --- extra/dns/server/server.factor | 38 ++++++++-------------------------- 1 file changed, 9 insertions(+), 29 deletions(-) diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index b556780805..3d59f0c3a6 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -1,6 +1,6 @@ -USING: kernel combinators sequences sets math threads - io.sockets unicode.case accessors +USING: kernel combinators sequences sets math threads namespaces continuations + debugger io io.sockets unicode.case accessors destructors combinators.cleave combinators.lib newfx fry dns dns.util dns.misc ; @@ -193,34 +193,14 @@ DEFER: query->rrs ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: (socket) ( -- vec ) V{ f } ; +: (handle-request) ( packet -- ) + [ [ find-answer ] with-message-bytes ] change-data respond ; -: socket ( -- socket ) (socket) 1st ; +: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ; -: init-socket-on-port ( port -- ) - f swap 0 (socket) as-mutate ; +: receive-loop ( socket -- ) + [ receive-packet handle-request ] [ receive-loop ] bi ; -: init-socket ( -- ) 53 init-socket-on-port ; +: loop ( addr-spec -- ) + [ '[ , [ receive-loop ] with-disposal ] try ] [ loop ] bi ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: (handle-request) ( byte-array addr-spec -- ) - >r - parse-message - find-answer - message->ba - r> - socket send ; - -: handle-request ( byte-array addr-spec -- ) - '[ , , (handle-request) ] in-thread ; - -: loop ( -- ) socket receive handle-request loop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: start ( -- ) init-socket loop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MAIN: start From 61fb8a538eb515d12c1b03b8af2a6c5b17fe43e8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 16 Jun 2008 16:37:52 -0500 Subject: [PATCH 45/71] dns.server: Use a variable for records --- extra/dns/server/server.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index 3d59f0c3a6..04b3ecfbee 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -9,7 +9,9 @@ IN: dns.server ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: records ( -- vector ) V{ } ; +SYMBOL: records-var + +: records ( -- records ) records-var get ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 0a436e1184a2c6e56315ac8efb4e1937d6e4aad4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:04:18 -0500 Subject: [PATCH 46/71] New threaded-server --- extra/io/server/server-docs.factor | 10 -- extra/io/server/server-tests.factor | 7 - extra/io/server/server.factor | 76 ---------- extra/io/server/summary.txt | 1 - .../connection}/authors.txt | 0 .../servers/connection/connection-docs.factor | 2 + .../connection/connection-tests.factor | 47 +++++++ extra/io/servers/connection/connection.factor | 131 ++++++++++++++++++ extra/io/servers/connection/summary.txt | 1 + .../{server => servers/connection}/tags.txt | 0 extra/io/servers/packet/authors.txt | 1 + extra/io/servers/packet/datagram.factor | 21 +++ extra/io/servers/packet/summary.txt | 1 + extra/io/servers/packet/tags.txt | 1 + extra/io/sockets/secure/secure-tests.factor | 5 +- extra/io/sockets/secure/secure.factor | 13 +- extra/io/sockets/sockets-docs.factor | 20 +-- extra/io/sockets/sockets-tests.factor | 2 +- extra/io/sockets/sockets.factor | 27 ++-- 19 files changed, 245 insertions(+), 121 deletions(-) delete mode 100755 extra/io/server/server-docs.factor delete mode 100755 extra/io/server/server-tests.factor delete mode 100755 extra/io/server/server.factor delete mode 100644 extra/io/server/summary.txt rename extra/io/{server => servers/connection}/authors.txt (100%) mode change 100755 => 100644 create mode 100755 extra/io/servers/connection/connection-docs.factor create mode 100755 extra/io/servers/connection/connection-tests.factor create mode 100755 extra/io/servers/connection/connection.factor create mode 100644 extra/io/servers/connection/summary.txt rename extra/io/{server => servers/connection}/tags.txt (100%) create mode 100755 extra/io/servers/packet/authors.txt create mode 100644 extra/io/servers/packet/datagram.factor create mode 100644 extra/io/servers/packet/summary.txt create mode 100644 extra/io/servers/packet/tags.txt diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor deleted file mode 100755 index 50f38cb146..0000000000 --- a/extra/io/server/server-docs.factor +++ /dev/null @@ -1,10 +0,0 @@ -USING: help help.syntax help.markup io ; -IN: io.server - -HELP: with-server -{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } } -{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ; - -HELP: with-datagrams -{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } } -{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ; diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor deleted file mode 100755 index 965a70718b..0000000000 --- a/extra/io/server/server-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -IN: io.server.tests -USING: tools.test io.server io.server.private kernel ; - -{ 2 0 } [ [ ] server-loop ] must-infer-as -{ 3 0 } [ [ ] with-connection ] must-infer-as -{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as -{ 2 0 } [ [ ] with-datagrams ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor deleted file mode 100755 index e975880a14..0000000000 --- a/extra/io/server/server.factor +++ /dev/null @@ -1,76 +0,0 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.sockets.secure io.files -io.streams.duplex logging continuations destructors kernel math -math.parser namespaces parser sequences strings prettyprint -debugger quotations calendar threads concurrency.combinators -assocs fry accessors arrays ; -IN: io.server - -SYMBOL: servers - -SYMBOL: remote-address - -> ] bi ] dip - '[ , , , , with-connection ] "Client" spawn drop - ] 2keep accept-loop ; inline - -: server-loop ( addrspec encoding quot -- ) - >r dup servers get push r> - '[ , accept-loop ] with-disposal ; inline - -\ server-loop NOTICE add-error-logging - -PRIVATE> - -: local-server ( port -- seq ) - "localhost" swap t resolve-host ; - -: internet-server ( port -- seq ) - f swap t resolve-host ; - -: secure-server ( port -- seq ) - internet-server [ ] map ; - -: with-server ( seq service encoding quot -- ) - V{ } clone servers [ - '[ , [ , , server-loop ] with-logging ] parallel-each - ] with-variable ; inline - -: stop-server ( -- ) - servers get dispose-each ; - - [ datagram-loop ] with-disposal ; inline - -\ spawn-datagrams NOTICE add-input-logging - -PRIVATE> - -: with-datagrams ( seq service quot -- ) - '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/server/summary.txt b/extra/io/server/summary.txt deleted file mode 100644 index e791b704eb..0000000000 --- a/extra/io/server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -TCP/IP and UDP/IP servers diff --git a/extra/io/server/authors.txt b/extra/io/servers/connection/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/io/server/authors.txt rename to extra/io/servers/connection/authors.txt diff --git a/extra/io/servers/connection/connection-docs.factor b/extra/io/servers/connection/connection-docs.factor new file mode 100755 index 0000000000..b033ec287c --- /dev/null +++ b/extra/io/servers/connection/connection-docs.factor @@ -0,0 +1,2 @@ +USING: help help.syntax help.markup io ; +IN: io.servers.connection diff --git a/extra/io/servers/connection/connection-tests.factor b/extra/io/servers/connection/connection-tests.factor new file mode 100755 index 0000000000..bb87d67917 --- /dev/null +++ b/extra/io/servers/connection/connection-tests.factor @@ -0,0 +1,47 @@ +IN: io.servers.connection +USING: tools.test io.servers.connection io.sockets namespaces +io.servers.connection.private kernel accessors sequences +concurrency.promises io.encodings.ascii io threads calendar ; + +[ t ] [ listen-on empty? ] unit-test + +[ f ] [ + + 25 internet-server >>insecure + listen-on + empty? +] unit-test + +[ t ] [ + T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 } + [ log-connection ] 2keep + [ remote-address get = ] [ local-address get = ] bi* + and +] unit-test + +[ ] [ init-server drop ] unit-test + +[ 10 ] [ + + 10 >>max-connections + init-server semaphore>> count>> +] unit-test + +[ ] [ "p" set ] unit-test + +[ ] [ + [ + + 5 >>max-connections + 1237 >>insecure + [ "Hello world." write stop-server ] >>handler + start-server + t "p" get fulfill + ] in-thread +] unit-test + +[ ] [ 100 sleep ] unit-test + +[ "Hello world." ] [ "localhost" 1237 ascii drop contents ] unit-test + +[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor new file mode 100755 index 0000000000..f01112a70f --- /dev/null +++ b/extra/io/servers/connection/connection.factor @@ -0,0 +1,131 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: continuations destructors kernel math math.parser +namespaces parser sequences strings prettyprint debugger +quotations combinators combinators.lib logging calendar assocs +fry accessors arrays io io.sockets io.encodings.ascii +io.sockets.secure io.files io.streams.duplex io.timeouts +io.encodings threads concurrency.combinators +concurrency.semaphores ; +IN: io.servers.connection + +TUPLE: threaded-server +name +secure insecure +secure-config +sockets +max-connections +semaphore +timeout +encoding +handler ; + +: local-server ( port -- addrspec ) "localhost" swap ; + +: internet-server ( port -- addrspec ) f swap ; + +: new-threaded-server ( class -- threaded-server ) + new + "server" >>name + ascii >>encoding + 1 minutes >>timeout + V{ } clone >>sockets + >>secure-config + [ "No handler quotation" throw ] >>handler ; inline + +: ( -- threaded-server ) + threaded-server new-threaded-server ; + +SYMBOL: remote-address + +GENERIC: handle-client* ( server -- ) + +insecure ( addrspec -- addrspec' ) + dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ; + +: >secure ( addrspec -- addrspec' ) + >insecure + dup { [ secure? ] [ not ] } 1|| [ ] unless ; + +: listen-on ( threaded-server -- addrspecs ) + [ secure>> >secure ] [ insecure>> >insecure ] bi + [ resolve-host ] bi@ append ; + +LOG: accepted-connection NOTICE + +: log-connection ( remote local -- ) + [ [ remote-address set ] [ local-address set ] bi* ] + [ 2array accepted-connection ] + 2bi ; + +M: threaded-server handle-client* handler>> call ; + +: handle-client ( client remote local -- ) + '[ + , , log-connection + threaded-server get + [ timeout>> timeouts ] [ handle-client* ] bi + ] with-stream ; + +: thread-name ( server-name addrspec -- string ) + unparse " connection from " swap 3append ; + +: accept-connection ( server -- ) + [ accept ] [ addr>> ] bi + [ '[ , , , handle-client ] ] + [ drop threaded-server get name>> swap thread-name ] 2bi + spawn drop ; + +: accept-loop ( server -- ) + [ + threaded-server get semaphore>> + [ [ accept-connection ] with-semaphore ] + [ accept-connection ] + if* + ] [ accept-loop ] bi ; inline + +\ accept-loop ERROR add-error-logging + +: start-accept-loop ( server -- ) + threaded-server get encoding>> + [ threaded-server get sockets>> push ] + [ [ accept-loop ] with-disposal ] + bi ; + +: init-server ( threaded-server -- threaded-server ) + dup semaphore>> [ + dup max-connections>> [ + >>semaphore + ] when* + ] unless ; + +PRIVATE> + +: start-server ( threaded-server -- ) + init-server + dup secure-config>> [ + dup threaded-server [ + dup name>> [ + listen-on [ + start-accept-loop + ] parallel-each + ] with-logging + ] with-variable + ] with-secure-context ; + +: stop-server ( -- ) + threaded-server get [ f ] change-sockets drop dispose-each ; + +GENERIC: port ( addrspec -- n ) + +M: integer port ; + +M: object port port>> ; + +: secure-port ( -- n ) + threaded-server get dup [ secure>> port ] when ; + +: insecure-port ( -- n ) + threaded-server get dup [ insecure>> port ] when ; diff --git a/extra/io/servers/connection/summary.txt b/extra/io/servers/connection/summary.txt new file mode 100644 index 0000000000..8269ecfc38 --- /dev/null +++ b/extra/io/servers/connection/summary.txt @@ -0,0 +1 @@ +Multi-threaded TCP/IP servers diff --git a/extra/io/server/tags.txt b/extra/io/servers/connection/tags.txt similarity index 100% rename from extra/io/server/tags.txt rename to extra/io/servers/connection/tags.txt diff --git a/extra/io/servers/packet/authors.txt b/extra/io/servers/packet/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/servers/packet/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/servers/packet/datagram.factor b/extra/io/servers/packet/datagram.factor new file mode 100644 index 0000000000..03596ee43c --- /dev/null +++ b/extra/io/servers/packet/datagram.factor @@ -0,0 +1,21 @@ +IN: io.servers.datagram + + [ datagram-loop ] with-disposal ; inline + +\ spawn-datagrams NOTICE add-input-logging + +PRIVATE> + +: with-datagrams ( seq service quot -- ) + '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/servers/packet/summary.txt b/extra/io/servers/packet/summary.txt new file mode 100644 index 0000000000..29247a2937 --- /dev/null +++ b/extra/io/servers/packet/summary.txt @@ -0,0 +1 @@ +Multi-threaded UDP/IP servers diff --git a/extra/io/servers/packet/tags.txt b/extra/io/servers/packet/tags.txt new file mode 100644 index 0000000000..992ae12982 --- /dev/null +++ b/extra/io/servers/packet/tags.txt @@ -0,0 +1 @@ +network diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor index 9b9436a8db..75ac39e190 100644 --- a/extra/io/sockets/secure/secure-tests.factor +++ b/extra/io/sockets/secure/secure-tests.factor @@ -1 +1,4 @@ -! No unit tests here, until Windows SSL is implemented +IN: io.sockets.secure.tests +USING: io.sockets.secure tools.test ; + +[ "hello" 24 ] [ "hello" 24 [ host>> ] [ port>> ] bi ] unit-test diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor index 448a5cdda0..10aec22ee5 100644 --- a/extra/io/sockets/secure/secure.factor +++ b/extra/io/sockets/secure/secure.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel symbols namespaces continuations -destructors io.sockets sequences inspector calendar ; +destructors io.sockets sequences inspector calendar delegate ; IN: io.sockets.secure SYMBOL: secure-socket-timeout @@ -42,8 +42,10 @@ TUPLE: secure addrspec ; C: secure -: resolve-secure-host ( host port passive? -- seq ) - resolve-host [ ] map ; +CONSULT: inet secure addrspec>> ; + +M: secure resolve-host ( secure -- seq ) + addrspec>> resolve-host [ ] map ; HOOK: check-certificate secure-socket-backend ( host handle -- ) @@ -53,9 +55,8 @@ PREDICATE: secure-inet < secure addrspec>> inet? ; M: secure-inet (client) [ - addrspec>> - [ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep - host>> pick handle>> check-certificate + [ resolve-host (client) [ |dispose ] dip ] keep + addrspec>> host>> pick handle>> check-certificate ] with-destructors ; PRIVATE> diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 78cddd5d3b..6aa46ccdbc 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -27,7 +27,7 @@ $nl { { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" } { { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" } } -"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface." +"The " { $vocab-link "io.servers.connection" } " library defines high-level wrappers around " { $link } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface." { $see-also "io.sockets.secure" } ; ARTICLE: "network-packet" "Packet-oriented networking" @@ -79,7 +79,7 @@ HELP: inet HELP: inet4 { $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes -"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible." +"Most applications do not operate on IPv4 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible." } { $examples { $code "\"127.0.0.1\" 8080 " } @@ -88,7 +88,7 @@ HELP: inet4 HELP: inet6 { $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes -"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." } +"Most applications do not operate on IPv6 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name." } { $examples { $code "\"::1\" 8080 " } } ; @@ -118,10 +118,10 @@ HELP: } { $notes "To start a TCP/IP server which listens for connections from any host, use an address specifier returned by the following code, where 1234 is the desired port number:" - { $code "f 1234 t resolve-host" } + { $code "f 1234 resolve-host" } "To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:" - { $code "\"localhost\" 1234 t resolve-host" } - "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this." + { $code "\"localhost\" 1234 resolve-host" } + "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this." $nl "To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:" { $unchecked-example @@ -148,9 +148,9 @@ HELP: } { $notes "To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:" - { $code "f 1234 t resolve-host" } + { $code "f 1234 resolve-host" } "To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:" - { $code "\"localhost\" 1234 t resolve-host" } + { $code "\"localhost\" 1234 resolve-host" } "Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly." "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding" } @@ -165,3 +165,7 @@ HELP: send { $values { "packet" byte-array } { "addrspec" "an address specifier" } { "datagram" "a datagram socket" } } { $description "Sends a packet to the given address." } { $errors "Throws an error if the packet could not be sent." } ; + +HELP: resolve-host +{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } } +{ $description "Resolves host names to IP addresses." } ; diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor index 8264bec032..4b95a31512 100755 --- a/extra/io/sockets/sockets-tests.factor +++ b/extra/io/sockets/sockets-tests.factor @@ -45,7 +45,7 @@ concurrency.promises threads io.streams.string ; [ "1:2:0:0:0:0:3:4" ] [ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test -[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test +[ t ] [ "localhost" 80 resolve-host length 1 >= ] unit-test ! Smoke-test UDP [ ] [ "127.0.0.1" 0 "datagram1" set ] unit-test diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 4efd30c65e..a9278c8357 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -259,20 +259,26 @@ HOOK: (send) io-backend ( packet addrspec datagram -- ) [ addrinfo>addrspec ] map sift ; -: prepare-resolve-host ( host serv passive? -- host' serv' flags ) +: prepare-resolve-host ( addrspec -- host' serv' flags ) #! If the port is a number, we resolve for 'http' then #! change it later. This is a workaround for a FreeBSD #! getaddrinfo() limitation -- on Windows, Linux and Mac, #! we can convert a number to a string and pass that as the #! service name, but on FreeBSD this gives us an unknown #! service error. - >r - dup integer? [ port-override set "http" ] when - r> AI_PASSIVE 0 ? ; + [ host>> ] + [ port>> dup integer? [ port-override set "http" ] when ] bi + over 0 AI_PASSIVE ? ; HOOK: addrinfo-error io-backend ( n -- ) -: resolve-host ( host serv passive? -- seq ) +GENERIC: resolve-host ( addrspec -- seq ) + +TUPLE: inet host port ; + +C: inet + +M: inet resolve-host [ prepare-resolve-host "addrinfo" @@ -284,17 +290,16 @@ HOOK: addrinfo-error io-backend ( n -- ) freeaddrinfo ] with-scope ; +M: f resolve-host drop { } ; + +M: object resolve-host 1array ; + : host-name ( -- string ) 256 dup dup length gethostname zero? [ "gethostname failed" throw ] unless ascii alien>string ; -TUPLE: inet host port ; - -C: inet - -M: inet (client) - [ host>> ] [ port>> ] bi f resolve-host (client) ; +M: inet (client) resolve-host (client) ; ERROR: invalid-inet-server addrspec ; From 24e9149a2e9528e5b1f8b1952953b5e3cfe05331 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:08:50 -0500 Subject: [PATCH 47/71] Updating code for new io.servers code --- .../distributed/distributed.factor | 21 +++++++++---------- extra/eval-server/authors.txt | 1 - extra/eval-server/eval-server.factor | 11 ---------- extra/eval-server/summary.txt | 1 - extra/eval-server/tags.txt | 4 ---- extra/smtp/server/server.factor | 2 +- extra/tty-server/tty-server.factor | 16 +++++++------- 7 files changed, 20 insertions(+), 36 deletions(-) delete mode 100644 extra/eval-server/authors.txt delete mode 100644 extra/eval-server/eval-server.factor delete mode 100644 extra/eval-server/summary.txt delete mode 100644 extra/eval-server/tags.txt diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index c637f4baa3..c9257eb27e 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: serialize sequences concurrency.messaging threads io -io.server qualified arrays namespaces kernel io.encodings.binary -accessors ; +io.servers.connection io.encodings.binary +qualified arrays namespaces kernel accessors ; FROM: io.sockets => host-name with-client ; IN: concurrency.distributed @@ -10,21 +10,20 @@ SYMBOL: local-node : handle-node-client ( -- ) deserialize - [ first2 get-process send ] - [ stop-server ] if* ; + [ first2 get-process send ] [ stop-server ] if* ; -: (start-node) ( addrspecs addrspec -- ) +: (start-node) ( addrspec addrspec -- ) local-node set-global [ - "concurrency.distributed" - binary - [ handle-node-client ] with-server + + swap >>insecure + binary >>encoding + "concurrency.distributed" >>name + [ handle-node-client ] >>handler ] curry "Distributed concurrency server" spawn drop ; : start-node ( port -- ) - [ internet-server ] - [ host-name swap ] bi - (start-node) ; + host-name over (start-node) ; TUPLE: remote-process id node ; diff --git a/extra/eval-server/authors.txt b/extra/eval-server/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/extra/eval-server/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/eval-server/eval-server.factor b/extra/eval-server/eval-server.factor deleted file mode 100644 index 3bfae616a2..0000000000 --- a/extra/eval-server/eval-server.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: listener io.server strings parser byte-arrays ; -IN: eval-server - -: eval-server ( -- ) - 9998 local-server "eval-server" [ - >string eval>string >byte-array - ] with-datagrams ; - -MAIN: eval-server diff --git a/extra/eval-server/summary.txt b/extra/eval-server/summary.txt deleted file mode 100644 index b75930ac9f..0000000000 --- a/extra/eval-server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Listens for UDP packets on localhost:9998, evaluates them and sends back result diff --git a/extra/eval-server/tags.txt b/extra/eval-server/tags.txt deleted file mode 100644 index f628c95985..0000000000 --- a/extra/eval-server/tags.txt +++ /dev/null @@ -1,4 +0,0 @@ -demos -network -tools -applications diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index 824651030d..a6a8bb2cca 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Elie CHAFTARI ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel prettyprint io io.timeouts io.server +USING: combinators kernel prettyprint io io.timeouts sequences namespaces io.sockets continuations calendar io.encodings.ascii io.streams.duplex destructors ; IN: smtp.server diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index d4b1a34e76..e155c2068d 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -1,11 +1,13 @@ -USING: listener io.server io.encodings.utf8 ; +USING: listener io.servers.connection io.encodings.utf8 ; IN: tty-server -: tty-server ( port -- ) - local-server - "tty-server" - utf8 [ listener ] with-server ; +: ( port -- ) + + "tty-server" >>name + utf8 >>encoding + swap local-server >>insecure + [ listener ] >>handler ; -: default-tty-server ( -- ) 9999 tty-server ; +: tty-server ( -- ) 9999 tty-server ; -MAIN: default-tty-server +MAIN: tty-server From dc7b414f5718423d1f6d91109fa11c26c4cf7e47 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:10:09 -0500 Subject: [PATCH 48/71] More flexible io.streams.limited, works with encoded streams --- extra/io/streams/limited/limited-tests.factor | 8 ++++++++ extra/io/streams/limited/limited.factor | 13 +++++++++---- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/extra/io/streams/limited/limited-tests.factor b/extra/io/streams/limited/limited-tests.factor index d160a3f756..eb5b921260 100644 --- a/extra/io/streams/limited/limited-tests.factor +++ b/extra/io/streams/limited/limited-tests.factor @@ -30,3 +30,11 @@ namespaces tools.test strings kernel ; [ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test [ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with + +[ "he" CHAR: l ] [ + B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } + ascii [ + 5 limit-input + "l" read-until + ] with-input-stream +] unit-test diff --git a/extra/io/streams/limited/limited.factor b/extra/io/streams/limited/limited.factor index 669240d28b..e89b31a884 100644 --- a/extra/io/streams/limited/limited.factor +++ b/extra/io/streams/limited/limited.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math io destructors accessors sequences -namespaces ; +USING: kernel math io io.encodings destructors accessors +sequences namespaces ; IN: io.streams.limited TUPLE: limited-stream stream count limit ; @@ -12,8 +12,13 @@ TUPLE: limited-stream stream count limit ; swap >>stream 0 >>count ; -: limit-input ( limit -- ) - input-stream [ swap ] change ; +GENERIC# limit 1 ( stream limit -- stream' ) + +M: decoder limit [ clone ] dip [ limit ] curry change-stream ; + +M: object limit ; + +: limit-input ( limit -- ) input-stream [ swap limit ] change ; ERROR: limit-exceeded ; From 5809df329a6f351d187eadd59b2abfbf5196ae5e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:10:18 -0500 Subject: [PATCH 49/71] Add a unit test --- extra/io/unix/sockets/secure/secure-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor index dca8fbbbc7..dee5c32349 100644 --- a/extra/io/unix/sockets/secure/secure-tests.factor +++ b/extra/io/unix/sockets/secure/secure-tests.factor @@ -14,7 +14,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ; "resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/dh1024.pem" >>dh-file "password" >>password - swap with-secure-context ; + swap with-secure-context ; inline :: server-test ( quot -- ) [ From cc605060b20d0928c0e9b803b1ab154b6ef33e1b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:10:46 -0500 Subject: [PATCH 50/71] Working on https server support --- extra/furnace/asides/asides.factor | 2 +- .../recover-password/recover-password.factor | 3 +- .../features/registration/registration.factor | 3 +- extra/furnace/auth/login/login.factor | 3 +- extra/furnace/flash/flash.factor | 2 +- extra/furnace/furnace.factor | 7 -- extra/furnace/redirection/redirection.factor | 29 ++++++ extra/furnace/sessions/sessions-tests.factor | 2 +- extra/furnace/sessions/sessions.factor | 7 +- extra/http/http-tests.factor | 2 +- extra/http/server/server.factor | 32 +++---- extra/webapps/blogs/blogs.factor | 1 + extra/webapps/pastebin/pastebin.factor | 1 + extra/webapps/planet/planet.factor | 1 + extra/webapps/todo/todo.factor | 1 + extra/webapps/user-admin/user-admin.factor | 1 + extra/webapps/wee-url/wee-url.factor | 2 +- extra/webapps/wiki/wiki.factor | 1 + .../concatenative/concatenative.factor | 88 +++++++++++++++++++ extra/websites/concatenative/page.css | 78 ++++++++++++++++ extra/websites/concatenative/page.xml | 28 ++++++ 21 files changed, 257 insertions(+), 37 deletions(-) create mode 100644 extra/furnace/redirection/redirection.factor create mode 100644 extra/websites/concatenative/concatenative.factor create mode 100644 extra/websites/concatenative/page.css create mode 100644 extra/websites/concatenative/page.xml diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor index 15d1c1df0b..9f1411188c 100644 --- a/extra/furnace/asides/asides.factor +++ b/extra/furnace/asides/asides.factor @@ -4,7 +4,7 @@ USING: accessors namespaces sequences arrays kernel assocs assocs.lib hashtables math.parser urls combinators html.elements html.templates.chloe.syntax db.types db.tuples http http.server http.server.filters -furnace furnace.cache furnace.sessions ; +furnace furnace.cache furnace.sessions furnace.redirection ; IN: furnace.asides TUPLE: aside < server-state session method url post-data ; diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor index 1e8d163e99..806df024f0 100644 --- a/extra/furnace/auth/features/recover-password/recover-password.factor +++ b/extra/furnace/auth/features/recover-password/recover-password.factor @@ -3,7 +3,8 @@ USING: namespaces accessors kernel assocs arrays io.sockets threads fry urls smtp validators html.forms http http.server.responses http.server.dispatchers -furnace furnace.actions furnace.auth furnace.auth.providers ; +furnace furnace.actions furnace.auth furnace.auth.providers +furnace.redirection ; IN: furnace.auth.features.recover-password SYMBOL: lost-password-from diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor index 2bc7688b10..5c1851fb64 100644 --- a/extra/furnace/auth/features/registration/registration.factor +++ b/extra/furnace/auth/features/registration/registration.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel namespaces validators html.forms urls http.server.dispatchers -furnace furnace.auth furnace.auth.providers furnace.actions ; +furnace furnace.auth furnace.auth.providers furnace.actions +furnace.redirection ; IN: furnace.auth.features.registration : ( -- action ) diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index e2b208de3a..4c53cb9c89 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -10,6 +10,7 @@ furnace.asides furnace.actions furnace.sessions furnace.utilities +furnace.redirection furnace.auth.login.permits ; IN: furnace.auth.login @@ -94,7 +95,7 @@ M: login-realm login-required* begin-aside protected get description>> description set protected get capabilities>> capabilities set - URL" $realm/login" flashed-variables ; + URL" $realm/login" >secure-url flashed-variables ; : ( responder name -- auth ) login-realm new-realm diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor index e06cdac090..2149e4fcd7 100644 --- a/extra/furnace/flash/flash.factor +++ b/extra/furnace/flash/flash.factor @@ -3,7 +3,7 @@ USING: namespaces assocs assocs.lib kernel sequences accessors urls db.types db.tuples math.parser fry http http.server http.server.filters http.server.redirection -furnace furnace.cache furnace.sessions ; +furnace furnace.cache furnace.sessions furnace.redirection ; IN: furnace.flash TUPLE: flash-scope < server-state session namespace ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 521f8a3bc1..90b529e385 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -63,13 +63,6 @@ M: url adjust-url M: string adjust-url ; -: ( url -- response ) - adjust-url request get method>> { - { "GET" [ ] } - { "HEAD" [ ] } - { "POST" [ ] } - } case ; - GENERIC: modify-form ( responder -- ) M: object modify-form drop ; diff --git a/extra/furnace/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor new file mode 100644 index 0000000000..7f87c677b9 --- /dev/null +++ b/extra/furnace/redirection/redirection.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors combinators namespaces +io.servers.connection +http http.server http.server.redirection +furnace ; +IN: furnace.redirection + +: ( url -- response ) + adjust-url request get method>> { + { "GET" [ ] } + { "HEAD" [ ] } + { "POST" [ ] } + } case ; + +: >secure-url ( url -- url' ) + clone + "https" >>protocol + secure-port >>port ; + +: ( url -- response ) + >secure-url ; + +TUPLE: redirect-responder to ; + +: ( url -- responder ) + redirect-responder boa ; + +M: redirect-responder call-responder* nip to>> ; diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor index a97ba091c0..98d1bbdfc9 100755 --- a/extra/furnace/sessions/sessions-tests.factor +++ b/extra/furnace/sessions/sessions-tests.factor @@ -1,7 +1,7 @@ IN: furnace.sessions.tests USING: tools.test http furnace.sessions furnace.actions http.server http.server.responses -math namespaces kernel accessors io.sockets io.server +math namespaces kernel accessors io.sockets io.servers.connection prettyprint io.streams.string io.files splitting destructors sequences db db.tuples db.sqlite continuations urls math.parser furnace ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 863b8f87cb..6e50417ea1 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math.intervals math.parser namespaces -random accessors quotations hashtables sequences continuations -fry calendar combinators combinators.lib destructors alarms io.server +strings random accessors quotations hashtables sequences continuations +fry calendar combinators combinators.lib destructors alarms +io.servers.connection db db.tuples db.types http http.server http.server.dispatchers http.server.filters html.elements @@ -109,7 +110,7 @@ M: session-saver dispose : request-session ( -- session/f ) session-id-key - client-state dup [ string>number ] when + client-state dup string? [ string>number ] when get-session verify-session ; : ( -- cookie ) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 73d26aa327..b5ed144579 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -123,7 +123,7 @@ read-response-test-1' 1array [ ! Live-fire exercise USING: http.server http.server.static furnace.sessions furnace.alloy furnace.actions furnace.auth furnace.auth.login furnace.db http.client -io.server io.files io io.encodings.ascii +io.servers.connection io.files io io.encodings.ascii accessors namespaces threads http.server.responses http.server.redirection http.server.dispatchers db.tuples ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index f709939e21..0312e62e8d 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -4,7 +4,6 @@ USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations combinators tools.vocabs tools.time math io -io.server io.sockets io.sockets.secure io.encodings @@ -12,6 +11,7 @@ io.encodings.utf8 io.encodings.ascii io.encodings.binary io.streams.limited +io.servers.connection io.timeouts fry logging logging.insomniac calendar urls http @@ -118,10 +118,6 @@ LOG: httpd-header NOTICE : ?refresh-all ( -- ) development? get-global [ global [ refresh-all ] bind ] when ; -: setup-limits ( -- ) - 1 minutes timeouts - 64 1024 * limit-input ; - LOG: httpd-benchmark DEBUG : ?benchmark ( quot -- ) @@ -130,25 +126,23 @@ LOG: httpd-benchmark DEBUG httpd-benchmark ] [ call ] if ; inline -: handle-client ( -- ) +TUPLE: http-server < threaded-server ; + +M: http-server handle-client* + drop [ - setup-limits - ascii decode-input - ascii encode-output + 64 1024 * limit-input ?refresh-all read-request [ do-request ] ?benchmark [ do-response ] ?benchmark ] with-destructors ; -: httpd ( port -- ) - dup integer? [ internet-server ] when - "http.server" binary [ handle-client ] with-server ; +: ( -- server ) + http-server new-threaded-server + "http.server" >>name + "http" protocol-port >>insecure + "https" protocol-port >>secure ; -: httpd-main ( -- ) - 8888 httpd ; - -: httpd-insomniac ( -- ) - "http.server" { httpd-hit } schedule-insomniac ; - -MAIN: httpd-main +: http-insomniac ( -- ) + "http.server" { "httpd-hit" } schedule-insomniac ; diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index aa1aa5edc7..10e0ab54c0 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -7,6 +7,7 @@ html.components http.server.dispatchers furnace furnace.actions +furnace.redirection furnace.auth furnace.auth.login furnace.boilerplate diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 251872d1ac..3aeb21420f 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -12,6 +12,7 @@ http.server.dispatchers http.server.redirection furnace furnace.actions +furnace.redirection furnace.auth furnace.auth.login furnace.boilerplate diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index b472881e73..ca74b7e642 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -10,6 +10,7 @@ http.server http.server.dispatchers furnace furnace.actions +furnace.redirection furnace.boilerplate furnace.auth.login furnace.auth diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 4b1b59e80f..0fb7e7dc89 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -11,6 +11,7 @@ furnace furnace.boilerplate furnace.auth furnace.actions +furnace.redirection furnace.db furnace.auth.login ; IN: webapps.todo diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 8c7b1b21c9..359730d4b2 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -12,6 +12,7 @@ furnace.auth.providers.db furnace.auth.login furnace.auth furnace.actions +furnace.redirection furnace.utilities http.server http.server.dispatchers ; diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index 2396e98b2a..27187c4352 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -4,7 +4,7 @@ USING: math.ranges sequences random accessors combinators.lib kernel namespaces fry db.types db.tuples urls validators html.components html.forms http http.server.dispatchers furnace -furnace.actions furnace.boilerplate ; +furnace.actions furnace.boilerplate furnace.redirection ; IN: webapps.wee-url TUPLE: wee-url < dispatcher ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 13c445b0a8..77ee242668 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -8,6 +8,7 @@ http.server http.server.dispatchers furnace furnace.actions +furnace.redirection furnace.auth furnace.auth.login furnace.boilerplate diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor new file mode 100644 index 0000000000..fcf98b08da --- /dev/null +++ b/extra/websites/concatenative/concatenative.factor @@ -0,0 +1,88 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences assocs io.files io.sockets +io.sockets.secure io.servers.connection +namespaces db db.tuples db.sqlite smtp urls +logging.insomniac +http.server +http.server.dispatchers +http.server.redirection +furnace.alloy +furnace.auth.login +furnace.auth.providers.db +furnace.auth.features.edit-profile +furnace.auth.features.recover-password +furnace.auth.features.registration +furnace.boilerplate +furnace.redirection +webapps.blogs +webapps.pastebin +webapps.planet +webapps.todo +webapps.wiki +webapps.wee-url +webapps.user-admin ; +IN: websites.concatenative + +: test-db ( -- db params ) "resource:test.db" sqlite-db ; + +: init-factor-db ( -- ) + test-db [ + init-furnace-tables + + { + post comment + paste annotation + blog posting + todo + short-url + article revision + } ensure-tables + ] with-db ; + +TUPLE: factor-website < dispatcher ; + +: ( -- responder ) + factor-website new-dispatcher + "blogs" add-responder + "todo" add-responder + "pastebin" add-responder + "planet" add-responder + "wiki" add-responder + "wee-url" add-responder + "user-admin" add-responder + URL" /wiki/view/Front Page" "" add-responder + "Factor website" + "Factor website" >>name + allow-registration + allow-password-recovery + allow-edit-profile + + { factor-website "page" } >>template + test-db ; + +: init-factor-website ( -- ) + "factorcode.org" 25 smtp-server set-global + "todo@factorcode.org" lost-password-from set-global + "website@factorcode.org" insomniac-sender set-global + "slava@factorcode.org" insomniac-recipients set-global + init-factor-db + main-responder set-global ; + +: ( -- config ) + + "resource:extra/openssl/test/server.pem" >>key-file + "resource:extra/openssl/test/dh1024.pem" >>dh-file + "password" >>password ; + +: ( -- threaded-server ) + + >>secure-config + 8080 >>insecure + 8431 >>secure ; + +: start-factor-website ( -- ) + test-db start-expiring + test-db start-update-task + http-insomniac + start-server ; diff --git a/extra/websites/concatenative/page.css b/extra/websites/concatenative/page.css new file mode 100644 index 0000000000..49e26883ad --- /dev/null +++ b/extra/websites/concatenative/page.css @@ -0,0 +1,78 @@ +body, button { + font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; + color:#444; +} + +.link-button { + padding: 0px; + background: none; + border: none; +} + +a, .link { + color: #222; + border-bottom:1px dotted #666; + text-decoration:none; +} + +a:hover, .link:hover { + border-bottom:1px solid #66a; +} + +.error { color: #a00; } + +.errors li { color: #a00; } + +.field-label { + text-align: right; +} + +.inline { + display: inline; +} + +.navbar { + background-color: #eee; + padding: 5px; + border: 1px solid #ccc; +} + +.big-field-label { + vertical-align: top; +} + +.description { + padding: 5px; + color: #000; +} + +.description pre { + border: 1px dashed #ccc; + background-color: #f5f5f5; +} + +.description p:first-child { + margin-top: 0px; +} + +.description p:last-child { + margin-bottom: 0px; +} + +.description table, .description td { + border-color: #666; + border-style: solid; +} + +.description table { + border-width: 0 0 1px 1px; + border-spacing: 0; + border-collapse: collapse; +} + +.description td { + margin: 0; + padding: 4px; + border-width: 1px 1px 0 0; +} + diff --git a/extra/websites/concatenative/page.xml b/extra/websites/concatenative/page.xml new file mode 100644 index 0000000000..464a3d9c5d --- /dev/null +++ b/extra/websites/concatenative/page.xml @@ -0,0 +1,28 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + From 44112e32e6d66429a0a344f56efd520b5bf5b177 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 05:21:45 -0500 Subject: [PATCH 51/71] Fix build errors --- .../distributed/distributed-tests.factor | 10 ++- .../distributed/distributed.factor | 1 + extra/io/servers/connection/connection.factor | 4 +- extra/io/sockets/secure/secure-tests.factor | 2 +- extra/tty-server/tty-server.factor | 8 +- extra/webapps/counter/counter.factor | 2 +- .../factor-website/factor-website.factor | 73 ----------------- extra/webapps/factor-website/page.css | 78 ------------------- extra/webapps/factor-website/page.xml | 28 ------- 9 files changed, 16 insertions(+), 190 deletions(-) delete mode 100644 extra/webapps/factor-website/factor-website.factor delete mode 100644 extra/webapps/factor-website/page.css delete mode 100644 extra/webapps/factor-website/page.xml diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index ca1da0deaa..dc20e7ad5c 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -1,9 +1,9 @@ IN: concurrency.distributed.tests USING: tools.test concurrency.distributed kernel io.files arrays io.sockets system combinators threads math sequences -concurrency.messaging continuations ; +concurrency.messaging continuations accessors prettyprint ; -: test-node +: test-node ( -- addrspec ) { { [ os unix? ] [ "distributed-concurrency-test" temp-file ] } { [ os windows? ] [ "127.0.0.1" 1238 ] } @@ -11,9 +11,9 @@ concurrency.messaging continuations ; [ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test -[ ] [ test-node dup 1array swap (start-node) ] unit-test +[ ] [ test-node dup (start-node) ] unit-test -[ ] [ 100 sleep ] unit-test +[ ] [ 1000 sleep ] unit-test [ ] [ [ @@ -30,4 +30,6 @@ concurrency.messaging continuations ; receive ] unit-test +[ ] [ 1000 sleep ] unit-test + [ ] [ test-node stop-node ] unit-test diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index c9257eb27e..9ae2627505 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -20,6 +20,7 @@ SYMBOL: local-node binary >>encoding "concurrency.distributed" >>name [ handle-node-client ] >>handler + start-server ] curry "Distributed concurrency server" spawn drop ; : start-node ( port -- ) diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor index f01112a70f..b062322142 100755 --- a/extra/io/servers/connection/connection.factor +++ b/extra/io/servers/connection/connection.factor @@ -86,14 +86,14 @@ M: threaded-server handle-client* handler>> call ; if* ] [ accept-loop ] bi ; inline -\ accept-loop ERROR add-error-logging - : start-accept-loop ( server -- ) threaded-server get encoding>> [ threaded-server get sockets>> push ] [ [ accept-loop ] with-disposal ] bi ; +\ start-accept-loop ERROR add-error-logging + : init-server ( threaded-server -- threaded-server ) dup semaphore>> [ dup max-connections>> [ diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor index 75ac39e190..78de43d379 100644 --- a/extra/io/sockets/secure/secure-tests.factor +++ b/extra/io/sockets/secure/secure-tests.factor @@ -1,4 +1,4 @@ IN: io.sockets.secure.tests -USING: io.sockets.secure tools.test ; +USING: accessors kernel io.sockets io.sockets.secure tools.test ; [ "hello" 24 ] [ "hello" 24 [ host>> ] [ port>> ] bi ] unit-test diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index e155c2068d..4ba38ad06a 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -1,4 +1,5 @@ -USING: listener io.servers.connection io.encodings.utf8 ; +USING: listener io.servers.connection io.encodings.utf8 +accessors kernel ; IN: tty-server : ( port -- ) @@ -6,8 +7,9 @@ IN: tty-server "tty-server" >>name utf8 >>encoding swap local-server >>insecure - [ listener ] >>handler ; + [ listener ] >>handler + start-server ; -: tty-server ( -- ) 9999 tty-server ; +: tty-server ( -- ) 9999 ; MAIN: tty-server diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 30c5d403de..a14d6d9823 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,5 +1,5 @@ USING: math kernel accessors http.server http.server.dispatchers -furnace furnace.actions furnace.sessions +furnace furnace.actions furnace.sessions furnace.redirection html.components html.forms html.templates.chloe fry urls ; IN: webapps.counter diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor deleted file mode 100644 index c0bd856d5d..0000000000 --- a/extra/webapps/factor-website/factor-website.factor +++ /dev/null @@ -1,73 +0,0 @@ -! Copyright (c) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences assocs io.files io.sockets -io.server -namespaces db db.tuples db.sqlite smtp -logging.insomniac -http.server -http.server.dispatchers -furnace.alloy -furnace.auth.login -furnace.auth.providers.db -furnace.auth.features.edit-profile -furnace.auth.features.recover-password -furnace.auth.features.registration -furnace.boilerplate -webapps.blogs -webapps.pastebin -webapps.planet -webapps.todo -webapps.wiki -webapps.wee-url -webapps.user-admin ; -IN: webapps.factor-website - -: test-db ( -- db params ) "resource:test.db" sqlite-db ; - -: init-factor-db ( -- ) - test-db [ - init-furnace-tables - - { - post comment - paste annotation - blog posting - todo - short-url - article revision - } ensure-tables - ] with-db ; - -TUPLE: factor-website < dispatcher ; - -: ( -- responder ) - factor-website new-dispatcher - "blogs" add-responder - "todo" add-responder - "pastebin" add-responder - "planet" add-responder - "wiki" add-responder - "wee-url" add-responder - "user-admin" add-responder - "Factor website" - "Factor website" >>name - allow-registration - allow-password-recovery - allow-edit-profile - - { factor-website "page" } >>template - test-db ; - -: init-factor-website ( -- ) - "factorcode.org" 25 smtp-server set-global - "todo@factorcode.org" lost-password-from set-global - "website@factorcode.org" insomniac-sender set-global - "slava@factorcode.org" insomniac-recipients set-global - init-factor-db - main-responder set-global ; - -: start-factor-website ( -- ) - test-db start-expiring - test-db start-update-task - httpd-insomniac - 8812 httpd ; diff --git a/extra/webapps/factor-website/page.css b/extra/webapps/factor-website/page.css deleted file mode 100644 index 49e26883ad..0000000000 --- a/extra/webapps/factor-website/page.css +++ /dev/null @@ -1,78 +0,0 @@ -body, button { - font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; - color:#444; -} - -.link-button { - padding: 0px; - background: none; - border: none; -} - -a, .link { - color: #222; - border-bottom:1px dotted #666; - text-decoration:none; -} - -a:hover, .link:hover { - border-bottom:1px solid #66a; -} - -.error { color: #a00; } - -.errors li { color: #a00; } - -.field-label { - text-align: right; -} - -.inline { - display: inline; -} - -.navbar { - background-color: #eee; - padding: 5px; - border: 1px solid #ccc; -} - -.big-field-label { - vertical-align: top; -} - -.description { - padding: 5px; - color: #000; -} - -.description pre { - border: 1px dashed #ccc; - background-color: #f5f5f5; -} - -.description p:first-child { - margin-top: 0px; -} - -.description p:last-child { - margin-bottom: 0px; -} - -.description table, .description td { - border-color: #666; - border-style: solid; -} - -.description table { - border-width: 0 0 1px 1px; - border-spacing: 0; - border-collapse: collapse; -} - -.description td { - margin: 0; - padding: 4px; - border-width: 1px 1px 0 0; -} - diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml deleted file mode 100644 index 32e1223c58..0000000000 --- a/extra/webapps/factor-website/page.xml +++ /dev/null @@ -1,28 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - From 27c89d75d46120df04769c3a375a7af2aa626443 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 05:22:33 -0500 Subject: [PATCH 52/71] I/O micro-optimizations; 12% improvement on reverse-complement --- core/io/encodings/encodings.factor | 102 ++++++++++-------- core/optimizer/known-words/known-words.factor | 20 ++-- extra/io/encodings/ascii/ascii.factor | 7 +- 3 files changed, 70 insertions(+), 59 deletions(-) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4a9f90cb32..942476616f 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -28,23 +28,62 @@ ERROR: encode-error ; ! Decoding - f decoder boa ; +>cr drop ; inline + +: cr- f >>cr drop ; inline + : >decoder< ( decoder -- stream encoding ) - [ stream>> ] [ code>> ] bi ; + [ stream>> ] [ code>> ] bi ; inline -: cr+ t swap set-decoder-cr ; inline +: fix-read1 ( stream char -- char ) + over cr>> [ + over cr- + dup CHAR: \n = [ + drop dup stream-read1 + ] when + ] when nip ; inline -: cr- f swap set-decoder-cr ; inline +M: decoder stream-read1 + dup >decoder< decode-char fix-read1 ; + +: fix-read ( stream string -- string ) + over cr>> [ + over cr- + "\n" ?head [ + over stream-read1 [ suffix ] when* + ] when + ] when nip ; inline + +: (read) ( n quot -- n string ) + over 0 [ + [ + >r call dup + [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if + ] 2curry find-integer + ] keep ; inline + +: finish-read ( n string -- string/f ) + { + { [ over 0 = ] [ 2drop f ] } + { [ over not ] [ nip ] } + [ swap head ] + } cond ; inline + +M: decoder stream-read + tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ; + +M: decoder stream-read-partial stream-read ; : line-ends/eof ( stream str -- str ) f like swap cr- ; inline : line-ends\r ( stream str -- str ) swap cr+ ; inline : line-ends\n ( stream str -- str ) - over decoder-cr over empty? and + over cr>> over empty? and [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline : handle-readln ( stream str ch -- str ) @@ -52,61 +91,30 @@ M: object f decoder boa ; { f [ line-ends/eof ] } { CHAR: \r [ line-ends\r ] } { CHAR: \n [ line-ends\n ] } - } case ; + } case ; inline -: fix-read ( stream string -- string ) - over decoder-cr [ - over cr- - "\n" ?head [ - over stream-read1 [ suffix ] when* - ] when - ] when nip ; - -: read-loop ( n stream -- string ) - SBUF" " clone [ - [ - >r nip stream-read1 dup - [ r> push f ] [ r> 2drop t ] if - ] 2curry find-integer drop - ] keep "" like f like ; - -M: decoder stream-read - tuck read-loop fix-read ; - -M: decoder stream-read-partial stream-read ; - -: (read-until) ( buf quot -- string/f sep/f ) +: ((read-until)) ( buf quot -- string/f sep/f ) ! quot: -- char stop? dup call [ >r drop "" like r> ] - [ pick push (read-until) ] if ; inline + [ pick push ((read-until)) ] if ; inline -M: decoder stream-read-until +: (read-until) ( seps stream -- string/f sep/f ) SBUF" " clone -rot >decoder< - [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry - (read-until) ; + [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry + ((read-until)) ; inline -: fix-read1 ( stream char -- char ) - over decoder-cr [ - over cr- - dup CHAR: \n = [ - drop dup stream-read1 - ] when - ] when nip ; +M: decoder stream-read-until (read-until) ; -M: decoder stream-read1 - dup >decoder< decode-char fix-read1 ; +M: decoder stream-readln "\r\n" over (read-until) handle-readln ; -M: decoder stream-readln ( stream -- str ) - "\r\n" over stream-read-until handle-readln ; - -M: decoder dispose decoder-stream dispose ; +M: decoder dispose stream>> dispose ; ! Encoding M: object encoder boa ; : >encoder< ( encoder -- stream encoding ) - [ stream>> ] [ code>> ] bi ; + [ stream>> ] [ code>> ] bi ; inline M: encoder stream-write1 >encoder< encode-char ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index d1dbefe26b..970b69a18a 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -9,7 +9,7 @@ io.streams.string layouts splitting math.intervals math.floats.private classes.tuple classes.tuple.private classes classes.algebra optimizer.def-use optimizer.backend optimizer.pattern-match optimizer.inlining float-arrays -sequences.private combinators ; +sequences.private combinators byte-arrays byte-vectors ; { } [ [ @@ -59,15 +59,19 @@ sequences.private combinators ; node-in-d peek dup value? [ value-literal sequence? ] [ drop f ] if ; -: member-quot ( seq -- newquot ) - [ literalize [ t ] ] { } map>assoc - [ drop f ] suffix [ nip case ] curry ; +: member-quot ( seq predicate -- newquot ) + [ curry [ dup ] prepose [ drop t ] ] curry { } map>assoc + [ drop f ] suffix [ nip cond ] curry ; -: expand-member ( #call -- ) - dup node-in-d peek value-literal member-quot f splice-quot ; +: expand-member ( #call predicate -- ) + >r dup node-in-d peek value-literal r> member-quot f splice-quot ; \ member? { - { [ dup literal-member? ] [ expand-member ] } + { [ dup literal-member? ] [ [ = ] expand-member ] } +} define-optimizers + +\ memq? { + { [ dup literal-member? ] [ [ eq? ] expand-member ] } } define-optimizers ! if the result of eq? is t and the second input is a literal, @@ -97,7 +101,7 @@ sequences.private combinators ; ] each \ push-all -{ { string sbuf } { array vector } } +{ { string sbuf } { array vector } { byte-array byte-vector } } "specializer" set-word-prop \ append diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index 9ff120c5fa..08dc8d07d9 100755 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -5,12 +5,11 @@ IN: io.encodings.ascii [ drop replacement-char ] unless ] - [ drop f ] if* ; + nip swap stream-read1 dup + [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline PRIVATE> SINGLETON: ascii From d17470b5fbf6f51f7d3f32a8f398b170e6f60e94 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 05:25:21 -0500 Subject: [PATCH 53/71] HTTPd test fixes --- extra/http/http-tests.factor | 2 +- extra/http/server/server.factor | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index b5ed144579..a02382f083 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -125,7 +125,7 @@ USING: http.server http.server.static furnace.sessions furnace.alloy furnace.actions furnace.auth furnace.auth.login furnace.db http.client io.servers.connection io.files io io.encodings.ascii accessors namespaces threads -http.server.responses http.server.redirection +http.server.responses http.server.redirection furnace.redirection http.server.dispatchers db.tuples ; : add-quit-action diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 0312e62e8d..21ab074907 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -144,5 +144,11 @@ M: http-server handle-client* "http" protocol-port >>insecure "https" protocol-port >>secure ; +: httpd ( port -- ) + + swap >>insecure + f >>secure + start-server ; + : http-insomniac ( -- ) "http.server" { "httpd-hit" } schedule-insomniac ; From 0c0aaceedb84a947d0127a404a4bdee07b858840 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:32:38 -0500 Subject: [PATCH 54/71] Better compilation of member? when the sequence contains small integers only --- core/optimizer/known-words/known-words.factor | 60 +++++++++++++++---- 1 file changed, 50 insertions(+), 10 deletions(-) diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 970b69a18a..7f882d85d0 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. IN: optimizer.known-words USING: alien arrays generic hashtables inference.dataflow -inference.class kernel assocs math math.private kernel.private -sequences words parser vectors strings sbufs io namespaces -assocs quotations sequences.private io.binary +inference.class kernel assocs math math.order math.private +kernel.private sequences words parser vectors strings sbufs io +namespaces assocs quotations sequences.private io.binary io.streams.string layouts splitting math.intervals math.floats.private classes.tuple classes.tuple.private classes classes.algebra optimizer.def-use optimizer.backend @@ -59,19 +59,59 @@ sequences.private combinators byte-arrays byte-vectors ; node-in-d peek dup value? [ value-literal sequence? ] [ drop f ] if ; -: member-quot ( seq predicate -- newquot ) - [ curry [ dup ] prepose [ drop t ] ] curry { } map>assoc - [ drop f ] suffix [ nip cond ] curry ; +: expand-member ( #call quot -- ) + >r dup node-in-d peek value-literal r> call f splice-quot ; -: expand-member ( #call predicate -- ) - >r dup node-in-d peek value-literal r> member-quot f splice-quot ; +: bit-member-n 256 ; inline + +: bit-member? ( seq -- ? ) + #! Can we use a fast byte array test here? + { + { [ dup length 8 < ] [ f ] } + { [ dup [ integer? not ] contains? ] [ f ] } + { [ dup [ 0 < ] contains? ] [ f ] } + { [ dup [ bit-member-n >= ] contains? ] [ f ] } + [ t ] + } cond nip ; + +: bit-member-seq ( seq -- flags ) + bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ; + +: exact-float? ( f -- ? ) + dup float? [ dup >integer >float = ] [ drop f ] if ; inline + +: bit-member-quot ( seq -- newquot ) + [ + [ drop ] % ! drop the sequence itself; we don't use it at run time + bit-member-seq , + [ + { + { [ over fixnum? ] [ ?nth 1 eq? ] } + { [ over bignum? ] [ ?nth 1 eq? ] } + { [ over exact-float? ] [ ?nth 1 eq? ] } + [ 2drop f ] + } cond + ] % + ] [ ] make ; + +: member-quot ( seq -- newquot ) + dup bit-member? [ + bit-member-quot + ] [ + [ [ t ] ] { } map>assoc + [ drop f ] suffix [ nip case ] curry + ] if ; \ member? { - { [ dup literal-member? ] [ [ = ] expand-member ] } + { [ dup literal-member? ] [ [ member-quot ] expand-member ] } } define-optimizers +: memq-quot ( seq -- newquot ) + [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc + [ drop f ] suffix [ nip cond ] curry ; + \ memq? { - { [ dup literal-member? ] [ [ eq? ] expand-member ] } + { [ dup literal-member? ] [ [ memq-quot ] expand-member ] } } define-optimizers ! if the result of eq? is t and the second input is a literal, From dc3929f3db12a47e20798567aba8c2754a24459b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:35:19 -0500 Subject: [PATCH 55/71] Improve PEG: word --- extra/peg/parsers/parsers.factor | 2 -- extra/peg/peg.factor | 25 ++++++++++++++++++------- 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 443b9fc61d..da44c12e8f 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -24,11 +24,9 @@ MEMO: just ( parser -- parser ) : 1token ( ch -- parser ) 1string token ; -r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq [ unclip 1vector swap first append ] action ; -PRIVATE> : list-of ( items separator -- parser ) hide f (list-of) ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index b420574a3b..05f84afedb 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences strings fry namespaces math assocs shuffle +USING: kernel sequences strings fry namespaces math assocs shuffle debugger io vectors arrays math.parser math.order unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting ; @@ -563,11 +563,22 @@ PRIVATE> #! to fix boxes so this isn't needed... box-parser boa next-id f over set-delegate [ ] action ; +ERROR: parse-failed input word ; + +M: parse-failed error. + "The " write dup word>> pprint " word could not parse the following input:" print nl + input>> . ; + : PEG: - (:) [ + (:) + [let* | def [ ] word [ ] compiled-def [ def call compile ] | [ - call compile [ compiled-parse ] curry - [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ] - append define - ] with-compilation-unit - ] 2curry over push-all ; parsing + [ + [ + dup compiled-def compiled-parse + [ ast>> ] [ word parse-failed ] ?if + ] + word swap define + ] with-compilation-unit + ] over push-all + ] ; parsing From c19d83e13f5b9330a09a7d74b5b7a01a3e403fba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:35:34 -0500 Subject: [PATCH 56/71] Use fry in html --- extra/html/elements/elements.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 5fc4bd19ae..35e01227b5 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -5,7 +5,7 @@ USING: io kernel namespaces prettyprint quotations sequences strings words xml.entities compiler.units effects -urls math math.parser combinators present ; +urls math math.parser combinators present fry ; IN: html.elements @@ -70,7 +70,7 @@ SYMBOL: html : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry + dup swap '[ , write-html ] (( -- )) html-word ; : ( str -- foo> ) ">" append ; @@ -93,14 +93,14 @@ SYMBOL: html : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup [ write-html ] curry (( -- )) html-word ; + dup '[ , write-html ] (( -- )) html-word ; : ( str -- ) "<" swap "/>" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry + dup swap '[ , write-html ] (( -- )) html-word ; : foo/> ( str -- str/> ) "/>" append ; @@ -134,7 +134,7 @@ SYMBOL: html : define-attribute-word ( name -- ) dup "=" prepend swap - [ write-attr ] curry (( string -- )) html-word ; + '[ , write-attr ] (( string -- )) html-word ; ! Define some closed HTML tags [ From 9674541cebfbb6bddfc135f3b3c9af892615236a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:36:20 -0500 Subject: [PATCH 57/71] New http request/response parsers using pegs --- extra/http/http-tests.factor | 49 ++++++- extra/http/http.factor | 224 ++++++++++++++---------------- extra/http/parsers/parsers.factor | 166 ++++++++++++++++++++++ 3 files changed, 315 insertions(+), 124 deletions(-) create mode 100644 extra/http/parsers/parsers.factor diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index a02382f083..522d0c1845 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,7 +1,8 @@ USING: http tools.test multiline tuple-syntax io.streams.string io.encodings.utf8 io.encodings.string kernel arrays splitting sequences -assocs io.sockets db db.sqlite continuations urls hashtables ; +assocs io.sockets db db.sqlite continuations urls hashtables +accessors ; IN: http.tests : lf>crlf "\n" split "\r\n" join ; @@ -73,10 +74,21 @@ GET nested HTTP/1.0 ; -[ read-request-test-3 [ read-request ] with-string-reader ] +[ read-request-test-3 lf>crlf [ read-request ] with-string-reader ] [ "Bad request: URL" = ] must-fail-with +STRING: read-request-test-4 +GET /blah HTTP/1.0 +Host: "www.amazon.com" +; + +[ "www.amazon.com" ] +[ + read-request-test-4 lf>crlf [ read-request ] with-string-reader + "host" header +] unit-test + STRING: read-response-test-1 HTTP/1.1 404 not found Content-Type: text/html; charset=UTF-8 @@ -117,7 +129,38 @@ read-response-test-1' 1array [ [ t ] [ "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT" - dup parse-cookies unparse-cookies = + dup parse-set-cookie first unparse-set-cookie = +] unit-test + +[ t ] [ + "a=" + dup parse-set-cookie first unparse-set-cookie = +] unit-test + +STRING: read-response-test-2 +HTTP/1.1 200 Content follows +Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456 + + +; + +[ 2 ] [ + read-response-test-2 lf>crlf + [ read-response ] with-string-reader + cookies>> length +] unit-test + +STRING: read-response-test-3 +HTTP/1.1 200 Content follows +Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes + + +; + +[ 1 ] [ + read-response-test-3 lf>crlf + [ read-response ] with-string-reader + cookies>> length ] unit-test ! Live-fire exercise diff --git a/extra/http/http.factor b/extra/http/http.factor index 025e2c8441..4001301cb1 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel combinators math namespaces - -assocs sequences splitting sorting sets debugger +assocs assocs.lib sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present @@ -11,7 +10,9 @@ io.encodings.8-bit unicode.case unicode.categories qualified -urls html.templates xml xml.data xml.writer ; +urls html.templates xml xml.data xml.writer + +http.parsers ; EXCLUDE: fry => , ; @@ -19,40 +20,20 @@ IN: http : crlf ( -- ) "\r\n" write ; -: add-header ( value key assoc -- ) - [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ; - -: header-line ( line -- ) - dup first blank? [ - [ blank? ] left-trim - "last-header" get - "header" get - add-header - ] [ - ":" split1 dup [ - [ blank? ] left-trim - swap >lower dup "last-header" set - "header" get add-header - ] [ - 2drop - ] if - ] if ; - -: read-lf ( -- bytes ) - "\n" read-until CHAR: \n assert= ; - : read-crlf ( -- bytes ) "\r" read-until [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; -: (read-header) ( -- ) - read-crlf dup - empty? [ drop ] [ header-line (read-header) ] if ; +: (read-header) ( -- alist ) + [ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ; + +: process-header ( alist -- assoc ) + f swap [ [ swap or dup ] dip swap ] assoc-map nip + [ ?push ] histogram [ "; " join ] assoc-map + >hashtable ; : read-header ( -- assoc ) - H{ } clone [ - "header" [ (read-header) ] with-variable - ] keep ; + (read-header) process-header ; : header-value>string ( value -- string ) { @@ -63,47 +44,62 @@ IN: http : check-header-string ( str -- str ) #! http://en.wikipedia.org/wiki/HTTP_Header_Injection - dup "\r\n" intersect empty? + dup "\r\n\"" intersect empty? [ "Header injection attack" throw ] unless ; : write-header ( assoc -- ) >alist sort-keys [ - swap - check-header-string write ": " write - header-value>string check-header-string write crlf + [ check-header-string write ": " write ] + [ header-value>string check-header-string write crlf ] bi* ] assoc-each crlf ; -TUPLE: cookie name value path domain expires max-age http-only ; +TUPLE: cookie name value version comment path domain expires max-age http-only secure ; : ( value name -- cookie ) cookie new swap >>name swap >>value ; -: parse-cookies ( string -- seq ) +: parse-set-cookie ( string -- seq ) [ f swap - - ";" split [ - [ blank? ] trim "=" split1 swap >lower { + (parse-set-cookie) + [ + swap { + { "version" [ >>version ] } + { "comment" [ >>comment ] } { "expires" [ cookie-string>timestamp >>expires ] } { "max-age" [ string>number seconds >>max-age ] } { "domain" [ >>domain ] } { "path" [ >>path ] } { "httponly" [ drop t >>http-only ] } - { "" [ drop ] } + { "secure" [ drop t >>secure ] } [ dup , nip ] } case - ] each + ] assoc-each + drop + ] { } make ; +: parse-cookie ( string -- seq ) + [ + f swap + (parse-cookie) + [ + swap { + { "$version" [ >>version ] } + { "$domain" [ >>domain ] } + { "$path" [ >>path ] } + [ dup , nip ] + } case + ] assoc-each drop ] { } make ; : check-cookie-string ( string -- string' ) - dup "=;'\"" intersect empty? + dup "=;'\"\r\n" intersect empty? [ "Bad cookie name or value" throw ] unless ; -: (unparse-cookie) ( key value -- ) +: unparse-cookie-value ( key value -- ) { { f [ drop ] } { t [ check-cookie-string , ] } @@ -118,20 +114,30 @@ TUPLE: cookie name value path domain expires max-age http-only ; ] } case ; -: unparse-cookie ( cookie -- strings ) +: (unparse-cookie) ( cookie -- strings ) [ dup name>> check-cookie-string >lower - over value>> (unparse-cookie) - "path" over path>> (unparse-cookie) - "domain" over domain>> (unparse-cookie) - "expires" over expires>> (unparse-cookie) - "max-age" over max-age>> (unparse-cookie) - "httponly" over http-only>> (unparse-cookie) + over value>> unparse-cookie-value + "$path" over path>> unparse-cookie-value + "$domain" over domain>> unparse-cookie-value drop ] { } make ; -: unparse-cookies ( cookies -- string ) - [ unparse-cookie ] map concat "; " join ; +: unparse-cookie ( cookies -- string ) + [ (unparse-cookie) ] map concat "; " join ; + +: unparse-set-cookie ( cookie -- string ) + [ + dup name>> check-cookie-string >lower + over value>> unparse-cookie-value + "path" over path>> unparse-cookie-value + "domain" over domain>> unparse-cookie-value + "expires" over expires>> unparse-cookie-value + "max-age" over max-age>> unparse-cookie-value + "httponly" over http-only>> unparse-cookie-value + "secure" over secure>> unparse-cookie-value + drop + ] { } make "; " join ; TUPLE: request method @@ -141,6 +147,13 @@ header post-data cookies ; +: check-url ( string -- url ) + >url dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline + +: read-request-line ( request -- request ) + read-crlf parse-request-line first3 + [ >>method ] [ check-url >>url ] [ >>version ] tri* ; + : set-header ( request/response value key -- request/response ) pick header>> set-at ; @@ -155,27 +168,9 @@ cookies ; "close" "connection" set-header "Factor http.client" "user-agent" set-header ; -: read-method ( request -- request ) - " " read-until [ "Bad request: method" throw ] unless - >>method ; - : check-absolute ( url -- url ) dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline -: read-url ( request -- request ) - " " read-until [ - dup empty? [ drop read-url ] [ >url check-absolute >>url ] if - ] [ "Bad request: URL" throw ] if ; - -: parse-version ( string -- version ) - "HTTP/" ?head [ "Bad request: version" throw ] unless - dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ; - -: read-request-version ( request -- request ) - read-crlf [ CHAR: \s = ] left-trim - parse-version - >>version ; - : read-request-header ( request -- request ) read-header >>header ; @@ -210,7 +205,7 @@ TUPLE: post-data raw content content-type ; drop ; : extract-cookies ( request -- request ) - dup "cookie" header [ parse-cookies >>cookies ] when* ; + dup "cookie" header [ parse-cookie >>cookies ] when* ; : parse-content-type-attributes ( string -- attributes ) " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ; @@ -220,22 +215,18 @@ TUPLE: post-data raw content content-type ; : read-request ( -- request ) - read-method - read-url - read-request-version + read-request-line read-request-header read-post-data extract-host extract-cookies ; -: write-method ( request -- request ) - dup method>> write bl ; - -: write-request-url ( request -- request ) - dup url>> relative-url present write bl ; - -: write-version ( request -- request ) - "HTTP/" write dup request-version write crlf ; +: write-request-line ( request -- request ) + dup + [ method>> write bl ] + [ url>> relative-url present write bl ] + [ "HTTP/" write version>> write crlf ] + tri ; : url-host ( url -- string ) [ host>> ] [ port>> ] bi dup "http" protocol-port = @@ -249,7 +240,7 @@ TUPLE: post-data raw content content-type ; [ content-type>> "content-type" pick set-at ] bi ] when* - over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* + over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when* write-header ; GENERIC: >post-data ( object -- post-data ) @@ -274,9 +265,7 @@ M: f >post-data ; : write-request ( request -- ) unparse-post-data - write-method - write-request-url - write-version + write-request-line write-request-header write-post-data flush @@ -311,23 +300,13 @@ M: response clone [ clone ] change-header [ clone ] change-cookies ; -: read-response-version ( response -- response ) - " \t" read-until - [ "Bad response: version" throw ] unless - parse-version - >>version ; - -: read-response-code ( response -- response ) - " \t" read-until [ "Bad response: code" throw ] unless - string>number [ "Bad response: code" throw ] unless* - >>code ; - -: read-response-message ( response -- response ) - read-crlf >>message ; +: read-response-line ( response -- response ) + read-crlf parse-response-line first3 + [ >>version ] [ >>code ] [ >>message ] tri* ; : read-response-header ( response -- response ) read-header >>header - dup "set-cookie" header parse-cookies >>cookies + dup "set-cookie" header parse-set-cookie >>cookies dup "content-type" header [ parse-content-type [ >>content-type ] @@ -336,20 +315,15 @@ M: response clone : read-response ( -- response ) - read-response-version - read-response-code - read-response-message + read-response-line read-response-header ; -: write-response-version ( response -- response ) - "HTTP/" write - dup version>> write bl ; - -: write-response-code ( response -- response ) - dup code>> number>string write bl ; - -: write-response-message ( response -- response ) - dup message>> write crlf ; +: write-response-line ( response -- response ) + dup + [ "HTTP/" write version>> write bl ] + [ code>> present write bl ] + [ message>> write crlf ] + tri ; : unparse-content-type ( request -- content-type ) [ content-type>> "application/octet-stream" or ] @@ -357,19 +331,29 @@ M: response clone bi [ "; charset=" swap 3append ] when* ; +: ensure-domain ( cookie -- cookie ) + [ + request get url>> + host>> dup "localhost" = + [ drop ] [ or ] if + ] change-domain ; + : write-response-header ( response -- response ) - dup header>> clone - over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when* + #! We send one set-cookie header per cookie, because that's + #! what Firefox expects. + dup header>> >alist >vector over unparse-content-type "content-type" pick set-at + over cookies>> [ + ensure-domain unparse-set-cookie + "set-cookie" swap 2array over push + ] each write-header ; : write-response-body ( response -- response ) dup body>> call-template ; M: response write-response ( respose -- ) - write-response-version - write-response-code - write-response-message + write-response-line write-response-header flush drop ; @@ -403,9 +387,7 @@ body ; "1.1" >>version ; M: raw-response write-response ( respose -- ) - write-response-version - write-response-code - write-response-message + write-response-line write-response-body drop ; diff --git a/extra/http/parsers/parsers.factor b/extra/http/parsers/parsers.factor new file mode 100644 index 0000000000..33bfa4b202 --- /dev/null +++ b/extra/http/parsers/parsers.factor @@ -0,0 +1,166 @@ +USING: math math.order math.parser kernel combinators.lib +sequences sequences.deep peg peg.parsers assocs arrays +hashtables strings unicode.case namespaces ascii ; +IN: http.parsers + +: except ( quot -- parser ) + [ not ] compose satisfy ; inline + +: except-these ( quots -- parser ) + [ 1|| ] curry except ; inline + +: ctl? ( ch -- ? ) + { [ 0 31 between? ] [ 127 = ] } 1|| ; + +: tspecial? ( ch -- ? ) + "()<>@,;:\\\"/[]?={} \t" member? ; + +: 'token' ( -- parser ) + { [ ctl? ] [ tspecial? ] } except-these repeat1 ; + +: case-insensitive ( parser -- parser' ) + [ flatten >string >lower ] action ; + +: case-sensitive ( parser -- parser' ) + [ flatten >string ] action ; + +: 'space' ( -- parser ) + [ " \t" member? ] satisfy repeat0 hide ; + +: one-of ( strings -- parser ) + [ token ] map choice ; + +: 'http-method' ( -- parser ) + { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ; + +: 'url' ( -- parser ) + [ " \t\r\n" member? ] except repeat1 case-sensitive ; + +: 'http-version' ( -- parser ) + [ + "HTTP" token hide , + 'space' , + "/" token hide , + 'space' , + "1" token , + "." token , + { "0" "1" } one-of , + ] seq* [ concat >string ] action ; + +PEG: parse-request-line ( string -- triple ) + #! Triple is { method url version } + [ + 'space' , + 'http-method' , + 'space' , + 'url' , + 'space' , + 'http-version' , + 'space' , + ] seq* just ; + +: 'text' ( -- parser ) + [ ctl? ] except ; + +: 'response-code' ( -- parser ) + [ digit? ] satisfy 3 exactly-n [ string>number ] action ; + +: 'response-message' ( -- parser ) + 'text' repeat0 case-sensitive ; + +PEG: parse-response-line ( string -- triple ) + #! Triple is { version code message } + [ + 'space' , + 'http-version' , + 'space' , + 'response-code' , + 'space' , + 'response-message' , + ] seq* just ; + +: 'crlf' ( -- parser ) + "\r\n" token ; + +: 'lws' ( -- parser ) + [ " \t" member? ] satisfy repeat1 ; + +: 'qdtext' ( -- parser ) + { [ CHAR: " = ] [ ctl? ] } except-these ; + +: 'quoted-char' ( -- parser ) + "\\" token hide any-char 2seq ; + +: 'quoted-string' ( -- parser ) + 'quoted-char' 'qdtext' 2choice repeat0 "\"" "\"" surrounded-by ; + +: 'ctext' ( -- parser ) + { [ ctl? ] [ "()" member? ] } except-these ; + +: 'comment' ( -- parser ) + 'ctext' 'comment' 2choice repeat0 "(" ")" surrounded-by ; + +: 'field-name' ( -- parser ) + 'token' case-insensitive ; + +: 'field-content' ( -- parser ) + 'quoted-string' case-sensitive + 'text' repeat0 case-sensitive + 2choice ; + +PEG: parse-header-line ( string -- pair ) + #! Pair is either { name value } or { f value }. If f, its a + #! continuation of the previous header line. + [ + 'field-name' , + 'space' , + ":" token hide , + 'space' , + 'field-content' , + ] seq* + [ + 'lws' [ drop f ] action , + 'field-content' , + ] seq* + 2choice ; + +: 'word' ( -- parser ) + 'token' 'quoted-string' 2choice ; + +: 'value' ( -- parser ) + 'quoted-string' + [ ";" member? ] except repeat0 + 2choice case-sensitive ; + +: 'attr' ( -- parser ) + 'token' case-insensitive ; + +: 'av-pair' ( -- parser ) + [ + 'space' , + 'attr' , + 'space' , + [ "=" token , 'space' , 'value' , ] seq* [ peek ] action + epsilon [ drop f ] action + 2choice , + 'space' , + ] seq* ; + +: 'av-pairs' ( -- parser ) + 'av-pair' ";" token list-of optional ; + +PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ; + +: 'cookie-value' ( -- parser ) + [ + 'space' , + 'attr' , + 'space' , + "=" token hide , + 'space' , + 'value' , + 'space' , + ] seq* ; + +PEG: (parse-cookie) ( string -- alist ) + 'cookie-value' [ ";," member? ] satisfy list-of optional just ; From 9453415eb5f9196a3a7de44dd33ae27d0efd1ebb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:37:04 -0500 Subject: [PATCH 58/71] https support --- extra/furnace/auth/auth.factor | 27 +++++++++++++++----- extra/furnace/auth/login/login.factor | 13 +++++++--- extra/furnace/boilerplate/boilerplate.factor | 8 +++++- extra/furnace/redirection/redirection.factor | 16 ++++++++++-- 4 files changed, 51 insertions(+), 13 deletions(-) diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index d9f517aaf4..ae042f05bd 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets -destructors combinators +destructors combinators fry io.encodings.utf8 io.encodings.string io.binary random checksums checksums.sha2 html.forms @@ -10,6 +10,7 @@ http.server.filters http.server.dispatchers furnace furnace.actions +furnace.redirection furnace.boilerplate furnace.auth.providers furnace.auth.providers.db ; @@ -54,7 +55,7 @@ V{ } clone capabilities set-global : define-capability ( word -- ) capabilities get adjoin ; -TUPLE: realm < dispatcher name users checksum ; +TUPLE: realm < dispatcher name users checksum secure ; GENERIC: login-required* ( realm -- response ) @@ -67,7 +68,8 @@ GENERIC: logged-in-username ( realm -- username ) swap >>name swap >>default users-in-db >>users - sha-256 >>checksum ; inline + sha-256 >>checksum + t >>secure ; inline : users ( -- provider ) realm get users>> ; @@ -104,6 +106,16 @@ M: realm call-responder* ( path responder -- response ) : check-login ( password username -- user/f ) users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ; +: if-secure-realm ( quot -- ) + realm get secure>> [ if-secure ] [ call ] if ; inline + +TUPLE: secure-realm-only < filter-responder ; + +C: secure-realm-only + +M: secure-realm-only call-responder* + '[ , , call-next-method ] if-secure-realm ; + TUPLE: protected < filter-responder description capabilities ; : ( responder -- protected ) @@ -118,9 +130,12 @@ TUPLE: protected < filter-responder description capabilities ; } cond ; M: protected call-responder* ( path responder -- response ) - dup protected set - dup logged-in-user get check-capabilities - [ call-next-method ] [ 2drop realm get login-required* ] if ; + '[ + , , + dup protected set + dup logged-in-user get check-capabilities + [ call-next-method ] [ 2drop realm get login-required* ] if + ] if-secure-realm ; : ( responder -- responder' ) { realm "boilerplate" } >>template ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 4c53cb9c89..68161382c1 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -39,8 +39,11 @@ M: login-realm modify-form ( responder -- ) : ( -- cookie ) permit-id get realm get name>> permit-id-key "$login-realm" resolve-base-path >>path - realm get timeout>> from-now >>expires - realm get domain>> >>domain ; + realm get + [ timeout>> from-now >>expires ] + [ domain>> >>domain ] + [ secure>> >>secure ] + tri ; : put-permit-cookie ( response -- response' ) put-cookie ; @@ -82,7 +85,9 @@ SYMBOL: capabilities "password" value "username" value check-login [ successful-login ] [ login-failed ] if* - ] >>submit ; + ] >>submit + + ; : ( -- action ) @@ -99,6 +104,6 @@ M: login-realm login-required* : ( responder name -- auth ) login-realm new-realm - "login" add-responder + "login" add-responder "logout" add-responder 20 minutes >>timeout ; diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index a976199661..0e2a673d9b 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel namespaces +USING: accessors kernel math.order namespaces combinators.lib html.forms html.templates html.templates.chloe @@ -17,6 +17,12 @@ TUPLE: boilerplate < filter-responder template init ; swap >>responder [ ] >>init ; +: wrap-boilerplate? ( response -- ? ) + { + [ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ] + [ content-type>> "text/html" = ] + } 1&& ; + M:: boilerplate call-responder* ( path responder -- ) begin-form path responder call-next-method diff --git a/extra/furnace/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor index 7f87c677b9..88d621b573 100644 --- a/extra/furnace/redirection/redirection.factor +++ b/extra/furnace/redirection/redirection.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors combinators namespaces +USING: kernel accessors combinators namespaces fry io.servers.connection -http http.server http.server.redirection +http http.server http.server.redirection http.server.filters furnace ; IN: furnace.redirection @@ -27,3 +27,15 @@ TUPLE: redirect-responder to ; redirect-responder boa ; M: redirect-responder call-responder* nip to>> ; + +TUPLE: secure-only < filter-responder ; + +C: secure-only + +: if-secure ( quot -- ) + >r request get url>> protocol>> "http" = + [ request get url>> ] + r> if ; inline + +M: secure-only call-responder* + '[ , , call-next-method ] if-secure ; From 21d3380bf229ccc856b2afc4e7550d84aa6192c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:50:10 -0500 Subject: [PATCH 59/71] Bootstrap fix --- core/optimizer/known-words/known-words.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 7f882d85d0..d69a2f94bc 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -98,7 +98,7 @@ sequences.private combinators byte-arrays byte-vectors ; dup bit-member? [ bit-member-quot ] [ - [ [ t ] ] { } map>assoc + [ literalize [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ] if ; From 83099e01d4ecb4670c05f12e33023f211769d4f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:58:29 -0500 Subject: [PATCH 60/71] Fixing PEG: --- extra/peg/peg.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 05f84afedb..3d3b4ad626 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -571,14 +571,16 @@ M: parse-failed error. : PEG: (:) - [let* | def [ ] word [ ] compiled-def [ def call compile ] | + [let | word [ ] def [ ] | [ [ - [ - dup compiled-def compiled-parse - [ ast>> ] [ word parse-failed ] ?if + [let | compiled-def [ def call compile ] + [ + dup compiled-def compiled-parse + [ ast>> ] [ word parse-failed ] ?if + ] + word swap define ] - word swap define ] with-compilation-unit ] over push-all ] ; parsing From e55c674a2bf97bbf87a38aba0db752d6b03edae4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 01:18:39 -0500 Subject: [PATCH 61/71] Fix again --- extra/peg/peg.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3d3b4ad626..54c25778de 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -571,10 +571,10 @@ M: parse-failed error. : PEG: (:) - [let | word [ ] def [ ] | + [let | def [ ] word [ ] | [ [ - [let | compiled-def [ def call compile ] + [let | compiled-def [ def call compile ] | [ dup compiled-def compiled-parse [ ast>> ] [ word parse-failed ] ?if From 6d2ded44f28c0be26dbe33bfb9231f18a1db9d85 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 01:40:48 -0500 Subject: [PATCH 62/71] Launcher fix --- extra/io/unix/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 7f6b3396a1..365e51749d 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -31,7 +31,7 @@ USE: unix ] when* ; : redirect-fd ( oldfd fd -- ) - 2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ; + 2dup = [ 2drop ] [ dup2 io-error ] if ; : reset-fd ( fd -- ) #! We drop the error code because on *BSD, fcntl of From 6aa23fd7a2c93cff05fd89c3260abc281140a14c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 01:52:50 -0500 Subject: [PATCH 63/71] Fix http.client load error' --- extra/http/client/client.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 56957b021c..0b9224f171 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -79,13 +79,9 @@ ERROR: download-failed response body ; M: download-failed error. "HTTP download failed:" print nl - [ - response>> - write-response-code - write-response-message nl - drop - ] - [ body>> write ] bi ; + [ response>> write-response-line nl drop ] + [ body>> write ] + bi ; : check-response ( response data -- response data ) over code>> success? [ download-failed ] unless ; From ef29b725b8be7927a9f112ab2b5f699ca97aa260 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 01:59:29 -0500 Subject: [PATCH 64/71] Fix ftp.server load error --- extra/ftp/server/server.factor | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index cce69dde0f..c71eadb72f 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.8-bit io.encodings io.encodings.binary io.encodings.utf8 io.files -io.server io.sockets kernel math.parser namespaces sequences +io.sockets kernel math.parser namespaces sequences ftp io.unix.launcher.parser unicode.case splitting assocs -classes io.server destructors calendar io.timeouts +classes io.servers.connection destructors calendar io.timeouts io.streams.duplex threads continuations math concurrency.promises byte-arrays ; IN: ftp.server @@ -305,7 +305,10 @@ ERROR: not-a-directory ; [ drop unrecognized-command t ] } case [ handle-client-loop ] when ; -: handle-client ( -- ) +TUPLE: ftp-server < threaded-server ; + +M: ftp-server handle-client* ( server -- ) + drop [ "" [ host-name client set @@ -313,9 +316,14 @@ ERROR: not-a-directory ; ] with-directory ] with-destructors ; +: ( port -- server ) + ftp-server new-threaded-server + swap >>insecure + "ftp.server" >>name + latin1 >>encoding ; + : ftpd ( port -- ) - internet-server "ftp.server" - latin1 [ handle-client ] with-server ; + start-server ; : ftpd-main ( -- ) 2100 ftpd ; From 1260a87468dd1a83f6d35b38d3ac60844186ad30 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 02:52:49 -0500 Subject: [PATCH 65/71] Debugging 'recover password' --- .../features/recover-password/recover-1.xml | 2 +- .../features/recover-password/recover-3.xml | 2 +- .../features/recover-password/recover-4.xml | 2 +- .../recover-password/recover-password.factor | 30 +++++++++---------- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/furnace/auth/features/recover-password/recover-1.xml b/extra/furnace/auth/features/recover-password/recover-1.xml index 21fbe6fd39..46e52d5319 100644 --- a/extra/furnace/auth/features/recover-password/recover-1.xml +++ b/extra/furnace/auth/features/recover-password/recover-1.xml @@ -6,7 +6,7 @@

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.

- +
diff --git a/extra/furnace/auth/features/recover-password/recover-3.xml b/extra/furnace/auth/features/recover-password/recover-3.xml index 2e412d1f18..a71118ea31 100644 --- a/extra/furnace/auth/features/recover-password/recover-3.xml +++ b/extra/furnace/auth/features/recover-password/recover-3.xml @@ -6,7 +6,7 @@

Choose a new password for your account.

- +
diff --git a/extra/furnace/auth/features/recover-password/recover-4.xml b/extra/furnace/auth/features/recover-password/recover-4.xml index f5d02fa858..d71a01bc25 100755 --- a/extra/furnace/auth/features/recover-password/recover-4.xml +++ b/extra/furnace/auth/features/recover-password/recover-4.xml @@ -4,6 +4,6 @@ Recover lost password: step 4 of 4 -

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

+

Your password has been reset. You may now proceed.

diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor index 806df024f0..93b3a7ad73 100644 --- a/extra/furnace/auth/features/recover-password/recover-password.factor +++ b/extra/furnace/auth/features/recover-password/recover-password.factor @@ -1,8 +1,9 @@ ! Copyright (c) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces accessors kernel assocs arrays io.sockets threads -fry urls smtp validators html.forms -http http.server.responses http.server.dispatchers +fry urls smtp validators html.forms present +http http.server.responses http.server.redirection +http.server.dispatchers furnace furnace.actions furnace.auth furnace.auth.providers furnace.redirection ; IN: furnace.auth.features.recover-password @@ -13,13 +14,12 @@ SYMBOL: lost-password-from request get url>> host>> host-name or ; : new-password-url ( user -- url ) - "recover-3" - swap [ - [ username>> "username" set ] - [ ticket>> "ticket" set ] + URL" recover-3" clone + swap + [ username>> "username" set-query-param ] + [ ticket>> "ticket" set-query-param ] bi - ] H{ } make-assoc - derive-url ; + adjust-url relative-to-request ; : password-email ( user -- email ) @@ -35,7 +35,7 @@ SYMBOL: lost-password-from "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 % + swap new-password-url present % "\n\n" % "Love,\n" % "\n" % @@ -48,7 +48,7 @@ SYMBOL: lost-password-from : ( -- action ) - { realm "recover-1" } >>template + { realm "features/recover-password/recover-1" } >>template [ { @@ -64,12 +64,12 @@ SYMBOL: lost-password-from send-password-email ] when* - URL" $login/recover-2" + URL" $realm/recover-2" ] >>submit ; : ( -- action ) - { realm "recover-2" } >>template ; + { realm "features/recover-password/recover-2" } >>template ; : ( -- action ) @@ -80,7 +80,7 @@ SYMBOL: lost-password-from } validate-params ] >>init - { realm "recover-3" } >>template + { realm "features/recover-password/recover-3" } >>template [ { @@ -100,7 +100,7 @@ SYMBOL: lost-password-from "new-password" value >>encoded-password users update-user - URL" $login/recover-4" + URL" $realm/recover-4" ] [ <403> ] if* @@ -108,7 +108,7 @@ SYMBOL: lost-password-from : ( -- action ) - { realm "recover-4" } >>template ; + { realm "features/recover-password/recover-4" } >>template ; : allow-password-recovery ( login -- login ) From ef6807a4dd6786c349abb93ccbfdfb458d5a26a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 02:54:11 -0500 Subject: [PATCH 66/71] Tweak --- extra/websites/concatenative/concatenative.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index fcf98b08da..1e79b043e2 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -63,8 +63,8 @@ TUPLE: factor-website < dispatcher ; : init-factor-website ( -- ) "factorcode.org" 25 smtp-server set-global - "todo@factorcode.org" lost-password-from set-global - "website@factorcode.org" insomniac-sender set-global + "noreply@concatenative.org" lost-password-from set-global + "website@concatenative.org" insomniac-sender set-global "slava@factorcode.org" insomniac-recipients set-global init-factor-db main-responder set-global ; From 9ce8116fad5a079343eebef63d0cac7176927570 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:16:45 -0500 Subject: [PATCH 67/71] Fix 'delete user' --- extra/webapps/user-admin/user-admin.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 359730d4b2..f445b6f471 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -139,7 +139,7 @@ TUPLE: user-admin < dispatcher ; [ validate-username - select-tuple 1 >>deleted update-tuple + "username" value select-tuple 1 >>deleted update-tuple URL" $user-admin" ] >>submit ; From db6b24614fbfadf820a97af19a3cbc7299cf7ba4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:26:50 -0500 Subject: [PATCH 68/71] Improving user-admin tool --- .../deactivate-user/deactivate-user.factor | 22 +++++++++++++++++++ .../features/edit-profile/edit-profile.xml | 3 +++ .../features/registration/registration.factor | 5 +++-- extra/html/templates/chloe/chloe.factor | 5 ++--- extra/webapps/user-admin/user-admin.factor | 2 +- .../concatenative/concatenative.factor | 2 ++ 6 files changed, 33 insertions(+), 6 deletions(-) create mode 100644 extra/furnace/auth/features/deactivate-user/deactivate-user.factor diff --git a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor new file mode 100644 index 0000000000..49fa00353b --- /dev/null +++ b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs namespaces accessors db db.tuples urls +http.server.dispatchers +furnace.asides furnace.actions furnace.auth furnace.auth.providers ; +IN: furnace.auth.features.deactivate-user + +: ( -- action ) + + [ + logged-in-user get + 1 >>deleted + t >>changed? + drop + URL" $realm" end-aside + ] >>submit ; + +: allow-deactivation ( realm -- realm ) + "deactivate-user" add-responder ; + +: allow-deactivation? ( -- ? ) + realm get responders>> "deactivate-user" swap key? ; diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml index 011cc2bdf8..a9d7994e97 100644 --- a/extra/furnace/auth/features/edit-profile/edit-profile.xml +++ b/extra/furnace/auth/features/edit-profile/edit-profile.xml @@ -67,4 +67,7 @@ + + Delete User + diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor index 5c1851fb64..20a48d07d2 100644 --- a/extra/furnace/auth/features/registration/registration.factor +++ b/extra/furnace/auth/features/registration/registration.factor @@ -35,10 +35,11 @@ IN: furnace.auth.features.registration realm get init-user-profile URL" $realm" - ] >>submit ; + ] >>submit + ; : allow-registration ( login -- login ) - "register" add-responder ; + "register" add-responder ; : allow-registration? ( -- ? ) realm get responders>> "register" swap key? ; diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 32fe954178..103020ee0f 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -87,11 +87,10 @@ CHLOE: comment drop ; CHLOE: call-next-template drop call-next-template ; : attr>word ( value -- word/f ) - dup ":" split1 swap lookup - [ ] [ "No such word: " swap append throw ] ?if ; + ":" split1 swap lookup ; : if-satisfied? ( tag -- ? ) - [ "code" optional-attr [ attr>word execute ] [ t ] if* ] + [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ] [ "value" optional-attr [ value ] [ t ] if* ] bi and ; diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index f445b6f471..2137abbc2d 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -139,7 +139,7 @@ TUPLE: user-admin < dispatcher ; [ validate-username - "username" value select-tuple 1 >>deleted update-tuple + "username" value delete-tuples URL" $user-admin" ] >>submit ; diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index 1e79b043e2..a4f826d7f6 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -13,6 +13,7 @@ furnace.auth.providers.db furnace.auth.features.edit-profile furnace.auth.features.recover-password furnace.auth.features.registration +furnace.auth.features.deactivate-user furnace.boilerplate furnace.redirection webapps.blogs @@ -57,6 +58,7 @@ TUPLE: factor-website < dispatcher ; allow-registration allow-password-recovery allow-edit-profile + allow-deactivation { factor-website "page" } >>template test-db ; From 5a133ceeceab676eff63174e90b6232771a576c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:28:15 -0500 Subject: [PATCH 69/71] Security --- .../auth/features/deactivate-user/deactivate-user.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor index 49fa00353b..cf6a56c2d4 100644 --- a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor +++ b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor @@ -16,7 +16,9 @@ IN: furnace.auth.features.deactivate-user ] >>submit ; : allow-deactivation ( realm -- realm ) - "deactivate-user" add-responder ; + + "delete your profile" >>description + "deactivate-user" add-responder ; : allow-deactivation? ( -- ? ) realm get responders>> "deactivate-user" swap key? ; From 4e1e14566943ec4574a498f54dd359bbe123826f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:40:05 -0500 Subject: [PATCH 70/71] Tweaking config some more --- .../concatenative/concatenative.factor | 30 ++++++++++++++----- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index a4f826d7f6..6d65f10783 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -63,19 +63,33 @@ TUPLE: factor-website < dispatcher ; { factor-website "page" } >>template test-db ; -: init-factor-website ( -- ) - "factorcode.org" 25 smtp-server set-global +SYMBOL: key-password +SYMBOL: key-file +SYMBOL: dh-file + +: common-configuration ( -- ) + "concatenative.org" 25 smtp-server set-global "noreply@concatenative.org" lost-password-from set-global "website@concatenative.org" insomniac-sender set-global "slava@factorcode.org" insomniac-recipients set-global - init-factor-db - main-responder set-global ; + main-responder set-global + init-factor-db ; + +: init-testing ( -- ) + "resource:extra/openssl/test/dh1024.pem" dh-file set-global + "resource:extra/openssl/test/server.pem" key-file set-global + "password" key-password set-global + common-configuration ; + +: init-production ( -- ) + "/home/slava/cert/host.pem" key-file set-global + common-configuration ; : ( -- config ) - "resource:extra/openssl/test/server.pem" >>key-file - "resource:extra/openssl/test/dh1024.pem" >>dh-file - "password" >>password ; + key-file get >>key-file + dh-file get >>dh-file + key-password get >>password ; : ( -- threaded-server ) @@ -83,7 +97,7 @@ TUPLE: factor-website < dispatcher ; 8080 >>insecure 8431 >>secure ; -: start-factor-website ( -- ) +: start-website ( -- ) test-db start-expiring test-db start-update-task http-insomniac From ebb3423e4a5138c4d4985fd080278b298613a4b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:53:16 -0500 Subject: [PATCH 71/71] Fix assocs.lib tests --- extra/assocs/lib/lib-tests.factor | 4 ++++ extra/assocs/lib/lib.factor | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 extra/assocs/lib/lib-tests.factor diff --git a/extra/assocs/lib/lib-tests.factor b/extra/assocs/lib/lib-tests.factor new file mode 100644 index 0000000000..0bf8270088 --- /dev/null +++ b/extra/assocs/lib/lib-tests.factor @@ -0,0 +1,4 @@ +IN: assocs.lib.tests +USING: assocs.lib tools.test vectors ; + +{ 1 1 } [ [ ?push ] histogram ] must-infer-as diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 1c89c1eb16..14632df771 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -41,4 +41,4 @@ IN: assocs.lib : histogram ( assoc quot -- assoc' ) H{ } clone [ swap [ change-at ] 2curry assoc-each - ] keep ; + ] keep ; inline