From f1bb2cca2048f169ff922877ddb6b171cc4ff1b7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 31 Aug 2008 23:45:31 +0200 Subject: [PATCH 01/10] Fixing xml.generator tests --- basis/xml/generator/generator-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/xml/generator/generator-tests.factor b/basis/xml/generator/generator-tests.factor index d44b713e55..052e5eab7f 100644 --- a/basis/xml/generator/generator-tests.factor +++ b/basis/xml/generator/generator-tests.factor @@ -1,3 +1,3 @@ -USING: tools.test io.streams.string xml.generator xml.writer ; +USING: tools.test io.streams.string xml.generator xml.writer accessors ; [ "" ] -[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ write-item ] with-string-writer ] unit-test +[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-item ] with-string-writer ] unit-test From 4044da2c510adb41839f83d49f65d00848d9832a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 7 Sep 2008 01:33:06 +0200 Subject: [PATCH 02/10] Removing multimehtod dependency in perisistent.heaps --- basis/persistent/heaps/heaps.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/persistent/heaps/heaps.factor b/basis/persistent/heaps/heaps.factor index 81c9959f84..6381b91dc3 100644 --- a/basis/persistent/heaps/heaps.factor +++ b/basis/persistent/heaps/heaps.factor @@ -1,4 +1,4 @@ -USING: kernel accessors multi-methods locals combinators math arrays +USING: kernel accessors locals combinators math arrays assocs namespaces sequences ; IN: persistent.heaps ! These are minheaps @@ -36,14 +36,15 @@ PRIVATE> GENERIC: sift-down ( value prio left right -- heap ) -METHOD: sift-down { empty-heap empty-heap } ; - -METHOD: sift-down { singleton-heap empty-heap } +: singleton-sift-down ( value prio singleton empty -- heap ) 3dup drop prio>> <= [ ] [ drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip ] if ; +M: empty-heap sift-down + over singleton-heap? [ singleton-sift-down ] [ ] if ; + :: reroot-left ( value prio left right -- heap ) left value>> left prio>> value prio left left>> left right>> sift-down @@ -54,7 +55,7 @@ METHOD: sift-down { singleton-heap empty-heap } value prio right left>> right right>> sift-down ; -METHOD: sift-down { branch branch } +M: branch sift-down ! both arguments are branches 3dup [ prio>> <= ] both-with? [ ] [ 2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if ] if ; From 0691bde5446d346a7234d2119d7859a9fbf2f6fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Sep 2008 21:32:06 -0500 Subject: [PATCH 03/10] Tweak deploy tests to take less time --- basis/tools/deploy/backend/backend.factor | 2 +- basis/tools/deploy/deploy-tests.factor | 8 ++++---- basis/tools/deploy/test/1/deploy.factor | 16 ++++++++-------- basis/tools/deploy/test/2/deploy.factor | 14 +++++++------- basis/tools/deploy/test/3/deploy.factor | 14 +++++++------- basis/tools/deploy/test/4/deploy.factor | 14 +++++++------- basis/tools/deploy/test/5/deploy.factor | 14 +++++++------- 7 files changed, 41 insertions(+), 41 deletions(-) diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 723f9461a8..ae4f6a8d62 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -42,9 +42,9 @@ IN: tools.deploy.backend : bootstrap-profile ( -- profile ) { - { "threads" deploy-threads? } { "math" deploy-math? } { "compiler" deploy-compiler? } + { "threads" deploy-threads? } { "ui" deploy-ui? } { "random" deploy-random? } } [ nip get ] assoc-filter keys diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 3d007e566c..acee098b8f 100755 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -26,7 +26,7 @@ namespaces continuations layouts accessors ; [ t ] [ 1300000 small-enough? ] unit-test -[ "staging.threads-math-compiler-ui-strip.image" ] [ +[ "staging.math-compiler-threads-ui-strip.image" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name ] bind ] unit-test @@ -39,9 +39,9 @@ namespaces continuations layouts accessors ; ! ! [ t ] [ 1500000 small-enough? ] unit-test ! -! [ ] [ "bunny" shake-and-bake ] unit-test -! -! [ t ] [ 2500000 small-enough? ] unit-test +[ ] [ "bunny" shake-and-bake ] unit-test + +[ t ] [ 2500000 small-enough? ] unit-test { "tools.deploy.test.1" diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor index 098e99719e..6846b3b53e 100755 --- a/basis/tools/deploy/test/1/deploy.factor +++ b/basis/tools/deploy/test/1/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-c-types? f } - { deploy-name "tools.deploy.test.1" } - { deploy-io 2 } - { deploy-random? f } - { deploy-math? t } - { deploy-compiler? t } - { deploy-reflection 2 } - { "stop-after-last-window?" t } { deploy-threads? t } + { deploy-random? f } + { deploy-c-types? f } { deploy-ui? f } { deploy-word-props? f } { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 2 } + { deploy-name "tools.deploy.test.1" } + { deploy-compiler? t } + { deploy-reflection 1 } + { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index c6f46eede6..4c34a77b66 100755 --- a/basis/tools/deploy/test/2/deploy.factor +++ b/basis/tools/deploy/test/2/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 2 } - { deploy-ui? f } { deploy-threads? t } + { deploy-random? f } { deploy-c-types? f } + { deploy-ui? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 2 } { deploy-name "tools.deploy.test.2" } { deploy-compiler? t } - { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-word-defs? f } + { deploy-reflection 1 } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? t } } diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index 5f45b87e0d..84347164b6 100755 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 3 } - { deploy-ui? f } { deploy-threads? t } + { deploy-random? f } { deploy-c-types? f } + { deploy-ui? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 3 } { deploy-name "tools.deploy.test.3" } { deploy-compiler? t } - { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-word-defs? f } + { deploy-reflection 1 } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? t } } diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor index ea899e64c0..b1a6736bde 100644 --- a/basis/tools/deploy/test/4/deploy.factor +++ b/basis/tools/deploy/test/4/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 2 } - { deploy-ui? f } { deploy-threads? t } + { deploy-random? f } { deploy-c-types? f } + { deploy-ui? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 2 } { deploy-name "tools.deploy.test.4" } { deploy-compiler? t } - { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-word-defs? f } + { deploy-reflection 1 } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? t } } diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor index 797116e09b..f5f8bc0352 100644 --- a/basis/tools/deploy/test/5/deploy.factor +++ b/basis/tools/deploy/test/5/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 3 } - { deploy-ui? f } { deploy-threads? t } + { deploy-random? f } { deploy-c-types? f } + { deploy-ui? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 3 } { deploy-name "tools.deploy.test.5" } { deploy-compiler? t } - { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-word-defs? f } + { deploy-reflection 1 } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? t } } From 8fb26cd759c6fbb7729c6ebb54c8b86ac9a0c224 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Sep 2008 21:32:15 -0500 Subject: [PATCH 04/10] Tweak stage2 --- basis/bootstrap/stage2.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 2388d7b8f0..58ea725d1e 100755 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -50,7 +50,7 @@ SYMBOL: bootstrap-time default-image-name "output-image" set-global - "threads math compiler help io random tools ui ui.tools unicode handbook" "include" set-global + "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global "" "exclude" set-global parse-command-line From 5cbd1fe8fc6ac5fc0d0eb70eb8462d4383538d5e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Sep 2008 01:09:52 -0500 Subject: [PATCH 05/10] Remove unnecessary dependency on peg.expr --- extra/lisp/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 428e1221da..1b14f5bb34 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings +USING: kernel peg peg.ebnf math.parser sequences arrays strings combinators.lib math fry accessors lists combinators.short-circuit ; IN: lisp.parser From 59623414b6bac96d5c5015c4e55f711992b043cd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Sep 2008 01:10:12 -0500 Subject: [PATCH 06/10] Fix bug spotted by Ed --- basis/http/http.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/http/http.factor b/basis/http/http.factor index e450631d94..03cca05ff3 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -113,7 +113,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s { [ dup real? ] [ number>string ] } [ ] } cond - check-cookie-string "=" swap check-cookie-string 3append , + [ check-cookie-string ] bi@ "=" swap 3append , ] } case ; From 63d45679c9929bd1cb79c4e01451dec6acf8dcab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Sep 2008 01:10:25 -0500 Subject: [PATCH 07/10] Better logging --- basis/io/servers/connection/connection.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 1ed83956c3..f789f7b114 100755 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -73,7 +73,7 @@ M: threaded-server handle-client* handler>> call ; ] with-stream ; : thread-name ( server-name addrspec -- string ) - unparse " connection from " swap 3append ; + unparse-short " connection from " swap 3append ; : accept-connection ( threaded-server -- ) [ accept ] [ addr>> ] bi From 7a9806495f9a24a0d044829268b22512041f0711 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Sep 2008 01:11:09 -0500 Subject: [PATCH 08/10] Major Chloe overhaul: compiled templatess --- basis/furnace/auth/auth.factor | 27 ++-- .../features/registration/registration.factor | 3 +- .../chloe-tags/chloe-tags-tests.factor | 19 +++ basis/furnace/chloe-tags/chloe-tags.factor | 121 +++++++++++++++ .../conversations/conversations.factor | 3 +- basis/furnace/furnace.factor | 141 +++--------------- basis/furnace/redirection/redirection.factor | 18 ++- basis/html/templates/chloe/chloe-tests.factor | 17 +-- basis/html/templates/chloe/chloe.factor | 132 +++++----------- .../templates/chloe/compiler/compiler.factor | 127 ++++++++++++++++ .../chloe/components/components.factor | 35 +++++ .../html/templates/chloe/syntax/syntax.factor | 29 +--- basis/xml/writer/writer.factor | 7 +- 13 files changed, 394 insertions(+), 285 deletions(-) create mode 100644 basis/furnace/chloe-tags/chloe-tags-tests.factor create mode 100644 basis/furnace/chloe-tags/chloe-tags.factor create mode 100644 basis/html/templates/chloe/compiler/compiler.factor create mode 100644 basis/html/templates/chloe/components/components.factor diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index 4487759719..54e936a313 100755 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -134,22 +134,21 @@ TUPLE: protected < filter-responder description capabilities ; swap >>responder ; : have-capabilities? ( capabilities -- ? ) - logged-in-user get { - { [ dup not ] [ 2drop f ] } - { [ dup deleted>> 1 = ] [ 2drop f ] } - [ capabilities>> subset? ] - } cond ; + realm get secure>> secure-connection? not and [ drop f ] [ + logged-in-user get { + { [ dup not ] [ 2drop f ] } + { [ dup deleted>> 1 = ] [ 2drop f ] } + [ capabilities>> subset? ] + } cond + ] if ; M: protected call-responder* ( path responder -- response ) - '[ - , , - dup protected set - dup capabilities>> have-capabilities? - [ call-next-method ] [ - [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi* - realm get login-required* - ] if - ] if-secure-realm ; + dup protected set + dup capabilities>> have-capabilities? + [ call-next-method ] [ + [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi* + realm get login-required* + ] if ; : ( responder -- responder' ) { realm "boilerplate" } >>template ; diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor index 20a48d07d2..da58e2b2ed 100644 --- a/basis/furnace/auth/features/registration/registration.factor +++ b/basis/furnace/auth/features/registration/registration.factor @@ -36,7 +36,8 @@ IN: furnace.auth.features.registration URL" $realm" ] >>submit - ; + + ; : allow-registration ( login -- login ) "register" add-responder ; diff --git a/basis/furnace/chloe-tags/chloe-tags-tests.factor b/basis/furnace/chloe-tags/chloe-tags-tests.factor new file mode 100644 index 0000000000..f172ce36f6 --- /dev/null +++ b/basis/furnace/chloe-tags/chloe-tags-tests.factor @@ -0,0 +1,19 @@ +USING: html.forms furnace.chloe-tags tools.test ; +IN: furnace.chloe-tags.tests + +[ f ] [ f parse-query-attr ] unit-test + +[ f ] [ "" parse-query-attr ] unit-test + +[ H{ { "a" "b" } } ] [ + begin-form + "b" "a" set-value + "a" parse-query-attr +] unit-test + +[ H{ { "a" "b" } { "c" "d" } } ] [ + begin-form + "b" "a" set-value + "d" "c" set-value + "a,c" parse-query-attr +] unit-test diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor new file mode 100644 index 0000000000..22eddd77a2 --- /dev/null +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -0,0 +1,121 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel combinators assocs +namespaces sequences splitting words +fry urls multiline present qualified +xml +xml.data +xml.entities +xml.writer +xml.utilities +html.components +html.elements +html.forms +html.templates +html.templates.chloe +html.templates.chloe.compiler +html.templates.chloe.syntax +http +http.server +http.server.redirection +http.server.responses +furnace ; +QUALIFIED-WITH: assocs a +IN: furnace.chloe-tags + +! Chloe tags +: parse-query-attr ( string -- assoc ) + [ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ; + +: a-url-path ( href rest -- string ) + dup [ value ] when + [ [ "/" ?tail drop "/" ] dip present 3append ] when* ; + +: a-url ( href rest query value-name -- url ) + dup [ >r 3drop r> value ] [ + drop + + swap parse-query-attr >>query + -rot a-url-path >>path + adjust-url relative-to-request + ] if ; + +: compile-a-url ( tag -- ) + { + [ "href" required-attr compile-attr ] + [ "rest" optional-attr compile-attr ] + [ "query" optional-attr compile-attr ] + [ "value" optional-attr compile-attr ] + } cleave [ a-url ] [code] ; + +CHLOE: atom + [ compile-children>string ] [ compile-a-url ] bi + [ add-atom-feed ] [code] ; + +CHLOE: write-atom drop [ write-atom-feeds ] [code] ; + +: compile-link-attrs ( tag -- ) + #! Side-effects current namespace. + attrs>> '[ [ , _ link-attr ] each-responder ] [code] ; + +: a-start-tag ( tag -- ) + [ compile-link-attrs ] [ compile-a-url ] bi + [ ] [code] ; + +: a-end-tag ( tag -- ) + drop [ ] [code] ; + +CHLOE: a [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri ; + +: compile-hidden-form-fields ( for -- ) + '[ + , [ "," split [ hidden render ] each ] when* + nested-forms get " " join f like nested-forms-key hidden-form-field + [ modify-form ] each-responder + ] [code] ; + +: compile-form-attrs ( method action attrs -- ) + [
] [code] ; + +: form-start-tag ( tag -- ) + [ + [ "method" optional-attr "post" or ] + [ "action" required-attr ] + [ attrs>> non-chloe-attrs-only ] tri + compile-form-attrs + ] + [ "for" optional-attr compile-hidden-form-fields ] bi ; + +: form-end-tag ( tag -- ) + drop [
] [code] ; + +CHLOE: form + { + [ compile-link-attrs ] + [ form-start-tag ] + [ compile-children ] + [ form-end-tag ] + } cleave ; + +STRING: button-tag-markup + + + +; + +: add-tag-attrs ( attrs tag -- ) + attrs>> swap update ; + +CHLOE: button + button-tag-markup string>xml body>> + { + [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] + [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] + [ [ children>> ] dip "button" tag-named (>>children) ] + [ nip ] + } 2cleave compile-chloe-tag ; diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor index 7216978110..26b62f9b07 100644 --- a/basis/furnace/conversations/conversations.factor +++ b/basis/furnace/conversations/conversations.factor @@ -130,7 +130,8 @@ M: conversations call-responder* over post-data>> >>post-data over url>> >>url ] change - url>> path>> split-path + [ url>> url set ] + [ url>> path>> split-path ] bi conversations get responder>> call-responder ; \ end-aside-post DEBUG add-input-logging diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index 9dfaa49028..b90587fba8 100644 --- a/basis/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -1,30 +1,14 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel combinators assocs -continuations namespaces sequences splitting words -vocabs.loader classes strings -fry urls multiline present -xml -xml.data -xml.entities -xml.writer -html.components -html.elements -html.forms -html.templates -html.templates.chloe -html.templates.chloe.syntax -http -http.server -http.server.redirection -http.server.responses -qualified ; -QUALIFIED-WITH: assocs a -EXCLUDE: xml.utilities => children>string ; +USING: namespaces assocs sequences kernel classes splitting +vocabs.loader accessors strings combinators arrays +continuations present fry +urls html.elements +http http.server http.server.redirection ; IN: furnace : nested-responders ( -- seq ) - responder-nesting get a:values ; + responder-nesting get values ; : each-responder ( quot -- ) nested-responders swap each ; inline @@ -63,10 +47,25 @@ M: url adjust-url M: string adjust-url ; +GENERIC: link-attr ( tag responder -- ) + +M: object link-attr 2drop ; + GENERIC: modify-form ( responder -- ) M: object modify-form drop ; +: hidden-form-field ( value name -- ) + over [ + + ] [ 2drop ] if ; + +: nested-forms-key "__n" ; + : request-params ( request -- assoc ) dup method>> { { "GET" [ url>> query>> ] } @@ -110,98 +109,4 @@ SYMBOL: exit-continuation : with-exit-continuation ( quot -- ) '[ exit-continuation set @ ] callcc1 exit-continuation off ; -! Chloe tags -: parse-query-attr ( string -- assoc ) - [ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ; - -: a-url-path ( tag -- string ) - [ "href" required-attr ] - [ "rest" optional-attr dup [ value ] when ] bi - [ [ "/" ?tail drop "/" ] dip present 3append ] when* ; - -: a-url ( tag -- url ) - dup "value" optional-attr - [ value ] [ - - swap - [ a-url-path >>path ] - [ "query" optional-attr parse-query-attr >>query ] - bi - adjust-url relative-to-request - ] ?if ; - -CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ; - -CHLOE: write-atom drop write-atom-feeds ; - -GENERIC: link-attr ( tag responder -- ) - -M: object link-attr 2drop ; - -: link-attrs ( tag -- ) - #! Side-effects current namespace. - '[ , _ link-attr ] each-responder ; - -: a-start-tag ( tag -- ) - [ ] with-scope ; - -CHLOE: a - [ a-start-tag ] - [ process-tag-children ] - [ drop ] - tri ; - -: hidden-form-field ( value name -- ) - over [ - - ] [ 2drop ] if ; - -: nested-forms-key "__n" ; - -: form-magic ( tag -- ) - [ modify-form ] each-responder - nested-forms get " " join f like nested-forms-key hidden-form-field - "for" optional-attr [ "," split [ hidden render ] each ] when* ; - -: form-start-tag ( tag -- ) - [ - [ -
> non-chloe-attrs-only print-attrs ] - } cleave - form> - ] - [ form-magic ] bi - ] with-scope ; - -CHLOE: form - [ form-start-tag ] - [ process-tag-children ] - [ drop
] - tri ; - -STRING: button-tag-markup - - - -; - -: add-tag-attrs ( attrs tag -- ) - attrs>> swap update ; - -CHLOE: button - button-tag-markup string>xml body>> - { - [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] - [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] - [ [ children>string 1array ] dip "button" tag-named (>>children) ] - [ nip ] - } 2cleave process-chloe-tag ; +"furnace.chloe-tags" require diff --git a/basis/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor index 83941cd08f..942cafd21a 100644 --- a/basis/furnace/redirection/redirection.factor +++ b/basis/furnace/redirection/redirection.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors combinators namespaces fry -io.servers.connection urls -http http.server http.server.redirection http.server.filters -furnace ; +io.servers.connection urls http http.server +http.server.redirection http.server.responses +http.server.filters furnace ; IN: furnace.redirection : ( url -- response ) @@ -32,10 +32,14 @@ TUPLE: secure-only < filter-responder ; C: secure-only -: if-secure ( quot -- ) - >r url get protocol>> "http" = - [ url get ] - r> if ; inline +: secure-connection? ( -- ? ) url get protocol>> "https" = ; + +: if-secure ( quot -- response ) + { + { [ secure-connection? ] [ call ] } + { [ request get method>> "POST" = ] [ drop <400> ] } + [ drop url get ] + } cond ; inline M: secure-only call-responder* '[ , , call-next-method ] if-secure ; diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 0305b738af..9eb4a5709c 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -4,22 +4,7 @@ namespaces xml html.components html.forms splitting unicode.categories furnace accessors ; IN: html.templates.chloe.tests -[ f ] [ f parse-query-attr ] unit-test - -[ f ] [ "" parse-query-attr ] unit-test - -[ H{ { "a" "b" } } ] [ - begin-form - "b" "a" set-value - "a" parse-query-attr -] unit-test - -[ H{ { "a" "b" } { "c" "d" } } ] [ - begin-form - "b" "a" set-value - "d" "c" set-value - "a,c" parse-query-attr -] unit-test +reset-templates : run-template with-string-writer [ "\r\n\t" member? not ] filter diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index f40fc43b32..a03e42bb37 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -1,78 +1,53 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences combinators kernel namespaces -classes.tuple assocs splitting words arrays memoize -io io.files io.encodings.utf8 io.streams.string -unicode.case mirrors fry math urls present -multiline xml xml.data xml.writer xml.utilities +USING: accessors kernel sequences combinators kernel fry +namespaces classes.tuple assocs splitting words arrays memoize +io io.files io.encodings.utf8 io.streams.string unicode.case +mirrors math urls present multiline quotations xml xml.data html.forms html.elements html.components html.templates +html.templates.chloe.compiler +html.templates.chloe.components html.templates.chloe.syntax ; IN: html.templates.chloe ! Chloe is Ed's favorite web designer -SYMBOL: tag-stack - TUPLE: chloe path ; C: chloe -DEFER: process-template +CHLOE: chloe compile-children ; -: chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = ] assoc-filter ; - -: non-chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = not ] assoc-filter ; - -: chloe-tag? ( tag -- ? ) - dup xml? [ body>> ] when - { - { [ dup tag? not ] [ f ] } - { [ dup url>> chloe-ns = not ] [ f ] } - [ t ] - } cond nip ; - -: process-tag-children ( tag -- ) - [ process-template ] each ; - -CHLOE: chloe process-tag-children ; - -: children>string ( tag -- string ) - [ process-tag-children ] with-string-writer ; - -CHLOE: title children>string set-title ; +CHLOE: title compile-children>string [ set-title ] [code] ; CHLOE: write-title drop "head" tag-stack get member? "title" tag-stack get member? not and - [ write-title ] [ write-title ] if ; + [ write-title ] [ write-title ] ? [code] ; CHLOE: style - dup "include" optional-attr dup [ - swap children>string empty? [ - "style tag cannot have both an include attribute and a body" throw - ] unless - utf8 file-contents + dup "include" optional-attr [ + utf8 file-contents [ add-style ] [code-with] ] [ - drop children>string - ] if add-style ; + compile-children>string [ add-style ] [code] + ] ?if ; CHLOE: write-style - drop ; + drop [ ] [code] ; -CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ; +CHLOE: even + [ "index" value even? swap when ] process-children ; -CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ; +CHLOE: odd + [ "index" value odd? swap when ] process-children ; : (bind-tag) ( tag quot -- ) [ - [ "name" required-attr ] keep - '[ , process-tag-children ] - ] dip call ; inline + [ "name" required-attr compile-attr ] keep + ] dip process-children ; inline CHLOE: each [ with-each-value ] (bind-tag) ; @@ -80,22 +55,23 @@ CHLOE: bind-each [ with-each-object ] (bind-tag) ; CHLOE: bind [ with-form ] (bind-tag) ; -: error-message-tag ( tag -- ) - children>string render-error ; - CHLOE: comment drop ; -CHLOE: call-next-template drop call-next-template ; +CHLOE: call-next-template + drop reset-buffer \ call-next-template , ; : attr>word ( value -- word/f ) ":" split1 swap lookup ; -: if-satisfied? ( tag -- ? ) - [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ] - [ "value" optional-attr [ value ] [ t ] if* ] - bi and ; +: if>quot ( tag -- quot ) + [ + [ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ] + [ "value" optional-attr [ , \ value , ] [ t , ] if* ] + bi + \ and , + ] [ ] make ; -CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; +CHLOE: if dup if>quot [ swap when ] append process-children ; CHLOE-SINGLETON: label CHLOE-SINGLETON: link @@ -112,51 +88,13 @@ CHLOE-TUPLE: choice CHLOE-TUPLE: checkbox CHLOE-TUPLE: code -: process-chloe-tag ( tag -- ) - dup main>> dup tags get at - [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ; +MEMO: template-quot ( chloe -- quot ) + path>> ".xml" append utf8 read-xml + compile-template ; -: process-tag ( tag -- ) - { - [ main>> >lower tag-stack get push ] - [ write-start-tag ] - [ process-tag-children ] - [ write-end-tag ] - [ drop tag-stack get pop* ] - } cleave ; - -: expand-attrs ( tag -- tag ) - dup [ tag? ] [ xml? ] bi or [ - clone [ - [ "@" ?head [ value present ] when ] assoc-map - ] change-attrs - ] when ; - -: process-template ( xml -- ) - expand-attrs - { - { [ dup chloe-tag? ] [ process-chloe-tag ] } - { [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] } - { [ t ] [ write-item ] } - } cond ; - -: process-chloe ( xml -- ) - [ - V{ } clone tag-stack set - - nested-template? get [ - process-template - ] [ - { - [ prolog>> write-prolog ] - [ before>> write-chunk ] - [ process-template ] - [ after>> write-chunk ] - } cleave - ] if - ] with-scope ; +: reset-templates ( -- ) \ template-quot reset-memoized ; M: chloe call-template* - path>> ".xml" append utf8 read-xml process-chloe ; + template-quot call ; INSTANCE: chloe template diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor new file mode 100644 index 0000000000..5722245f89 --- /dev/null +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -0,0 +1,127 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs namespaces kernel sequences accessors combinators +strings splitting io io.streams.string xml.writer xml.data +xml.entities html.forms html.templates.chloe.syntax ; +IN: html.templates.chloe.compiler + +: chloe-attrs-only ( assoc -- assoc' ) + [ drop url>> chloe-ns = ] assoc-filter ; + +: non-chloe-attrs-only ( assoc -- assoc' ) + [ drop url>> chloe-ns = not ] assoc-filter ; + +: chloe-tag? ( tag -- ? ) + dup xml? [ body>> ] when + { + { [ dup tag? not ] [ f ] } + { [ dup url>> chloe-ns = not ] [ f ] } + [ t ] + } cond nip ; + +SYMBOL: string-buffer + +SYMBOL: tag-stack + +DEFER: compile-element + +: compile-children ( tag -- ) + [ compile-element ] each ; + +: [write] ( string -- ) string-buffer get push-all ; + +: reset-buffer ( -- ) + string-buffer get [ + [ >string , \ write , ] [ delete-all ] bi + ] unless-empty ; + +: [code] ( quot -- ) + reset-buffer % ; + +: [code-with] ( obj quot -- ) + reset-buffer [ , ] [ % ] bi* ; + +: expand-attr ( value -- ) + [ value write ] [code-with] ; + +: compile-attr ( value -- ) + reset-buffer "@" ?head [ , \ value ] when , ; + +: compile-attrs ( assoc -- ) + [ + " " [write] + swap name>string [write] + "=\"" [write] + "@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if + "\"" [write] + ] assoc-each ; + +: compile-start-tag ( tag -- ) + "<" [write] + [ name>string [write] ] [ compile-attrs ] bi + ">" [write] ; + +: compile-end-tag ( tag -- ) + "string [write] + ">" [write] ; + +: compile-tag ( tag -- ) + { + [ main>> tag-stack get push ] + [ compile-start-tag ] + [ compile-children ] + [ compile-end-tag ] + [ drop tag-stack get pop* ] + } cleave ; + +: compile-chloe-tag ( tag -- ) + ! "Unknown chloe tag: " prepend throw + dup main>> dup tags get at + [ curry assert-depth ] [ 2drop ] ?if ; + +: compile-element ( element -- ) + { + { [ dup chloe-tag? ] [ compile-chloe-tag ] } + { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] } + { [ dup string? ] [ escape-string [write] ] } + { [ dup comment? ] [ drop ] } + [ [ write-item ] [code-with] ] + } cond ; + +: with-compiler ( quot -- quot' ) + [ + SBUF" " string-buffer set + V{ } clone tag-stack set + call + reset-buffer + ] [ ] make ; inline + +: compile-nested-template ( xml -- quot ) + [ compile-element ] with-compiler ; + +: compile-chunk ( seq -- ) + [ compile-element ] each ; + +: process-children ( tag quot -- ) + reset-buffer + [ + [ + SBUF" " string-buffer set + compile-children + reset-buffer + ] [ ] make , + ] [ % ] bi* ; + +: compile-children>string ( tag -- ) + [ with-string-writer ] process-children ; + +: compile-template ( xml -- quot ) + [ + { + [ prolog>> [ write-prolog ] [code-with] ] + [ before>> compile-chunk ] + [ compile-element ] + [ after>> compile-chunk ] + } cleave + ] with-compiler ; diff --git a/basis/html/templates/chloe/components/components.factor b/basis/html/templates/chloe/components/components.factor new file mode 100644 index 0000000000..e8703a1235 --- /dev/null +++ b/basis/html/templates/chloe/components/components.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs sequences kernel parser fry quotations +classes.tuple +html.components +html.templates.chloe.compiler +html.templates.chloe.syntax ; +IN: html.templates.chloe.components + +: singleton-component-tag ( tag class -- ) + [ "name" required-attr compile-attr ] + [ literalize [ render ] [code-with] ] + bi* ; + +: CHLOE-SINGLETON: + scan-word + [ name>> ] [ '[ , singleton-component-tag ] ] bi + define-chloe-tag ; + parsing + +: compile-component-attrs ( tag class -- ) + [ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip + [ all-slots swap '[ name>> , at compile-attr ] each ] + [ [ boa ] [code-with] ] + bi ; + +: tuple-component-tag ( tag class -- ) + [ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi + [ render ] [code] ; + +: CHLOE-TUPLE: + scan-word + [ name>> ] [ '[ , tuple-component-tag ] ] bi + define-chloe-tag ; + parsing diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index 65b5cd8790..90c171917b 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -21,7 +21,7 @@ tags global [ H{ } clone or ] change-at : chloe-ns "http://factorcode.org/chloe/1.0" ; inline -MEMO: chloe-name ( string -- name ) +: chloe-name ( string -- name ) name new swap >>main chloe-ns >>url ; @@ -32,30 +32,3 @@ MEMO: chloe-name ( string -- name ) : optional-attr ( tag name -- value ) chloe-name swap at ; - -: singleton-component-tag ( tag class -- ) - [ "name" required-attr ] dip render ; - -: CHLOE-SINGLETON: - scan-word - [ name>> ] [ '[ , singleton-component-tag ] ] bi - define-chloe-tag ; - parsing - -: attrs>slots ( tag tuple -- ) - [ attrs>> ] [ ] bi* - '[ - swap main>> dup "name" = - [ 2drop ] [ , set-at ] if - ] assoc-each ; - -: tuple-component-tag ( tag class -- ) - [ drop "name" required-attr ] - [ new [ attrs>slots ] keep ] - 2bi render ; - -: CHLOE-TUPLE: - scan-word - [ name>> ] [ '[ , tuple-component-tag ] ] bi - define-chloe-tag ; - parsing diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 0c98e9a48e..6b60ec8a6d 100644 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -37,10 +37,11 @@ SYMBOL: indenter [ [ empty? ] [ string? ] bi and not ] filter ] when ; +: name>string ( name -- string ) + [ main>> ] [ space>> ] bi [ ":" swap 3append ] unless-empty ; + : print-name ( name -- ) - dup space>> f like - [ write CHAR: : write1 ] when* - main>> write ; + name>string write ; : print-attrs ( assoc -- ) [ From 977febf1fa4942daef8f876e571d1347def065a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Sep 2008 01:11:27 -0500 Subject: [PATCH 09/10] Wiki: cache Farkup HTML output --- extra/webapps/wiki/view.xml | 2 +- extra/webapps/wiki/wiki-common.xml | 4 ++-- extra/webapps/wiki/wiki.factor | 12 +++++++++--- 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml index 38d9d39d55..5136e4945d 100644 --- a/extra/webapps/wiki/view.xml +++ b/extra/webapps/wiki/view.xml @@ -5,7 +5,7 @@
- +

diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index dea79670a3..89a0f17706 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -41,7 +41,7 @@ - + @@ -52,7 +52,7 @@ - + diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 380f41cf97..5f679be431 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -3,7 +3,7 @@ USING: accessors kernel hashtables calendar random assocs namespaces splitting sequences sorting math.order present io.files io.encodings.ascii -syndication +syndication farkup html.components html.forms http.server http.server.dispatchers @@ -47,7 +47,7 @@ article "ARTICLES" { :

( title -- article ) article new swap >>title ; -TUPLE: revision id title author date content description ; +TUPLE: revision id title author date content html description ; revision "REVISIONS" { { "id" "ID" INTEGER +db-assigned-id+ } @@ -55,6 +55,7 @@ revision "REVISIONS" { { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid { "date" "DATE" TIMESTAMP +not-null+ } { "content" "CONTENT" TEXT +not-null+ } + { "html" "HTML" TEXT +not-null+ } ! Farkup converted to HTML { "description" "DESCRIPTION" TEXT } } define-persistent @@ -71,6 +72,9 @@ M: revision feed-entry-url id>> revision-url ; : ( id -- revision ) revision new swap >>id ; +: compute-html ( revision -- ) + dup content>> convert-farkup >>html drop ; + : validate-title ( -- ) { { "title" [ v-one-line ] } } validate-params ; @@ -144,11 +148,13 @@ M: revision feed-entry-url id>> revision-url ; [ title>> ] [ id>> ] bi article boa insert-tuple ; : add-revision ( revision -- ) + [ compute-html ] [ insert-tuple ] [ dup title>>
select-tuple [ amend-article ] [ add-article ] if* - ] bi ; + ] + tri ; : ( -- action ) From b9f0795c53b086322a2013648dfea81d359b2079 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Sep 2008 01:11:36 -0500 Subject: [PATCH 10/10] Minor tweak --- extra/websites/concatenative/concatenative.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index 11d8fa27c2..5e94e4e88a 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -4,6 +4,7 @@ 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 +html.templates.chloe http.server http.server.dispatchers http.server.redirection @@ -68,6 +69,7 @@ SYMBOL: key-file SYMBOL: dh-file : common-configuration ( -- ) + reset-templates "concatenative.org" 25 smtp-server set-global "noreply@concatenative.org" lost-password-from set-global "website@concatenative.org" insomniac-sender set-global