Merge branch 'master' into public
* master: Minor tweak Wiki: cache Farkup HTML output Major Chloe overhaul: compiled templatess Better logging Fix bug spotted by Ed Remove unnecessary dependency on peg.expr Tweak stage2 Tweak deploy tests to take less time Removing multimehtod dependency in perisistent.heaps Fixing xml.generator testsdb4
Aaron Schaefer
commit
700ec268c8
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <auth-boilerplate> ( responder -- responder' )
|
||||
<boilerplate> { realm "boilerplate" } >>template ;
|
||||
|
|
|
|||
|
|
@ -36,7 +36,8 @@ IN: furnace.auth.features.registration
|
|||
|
||||
URL" $realm" <redirect>
|
||||
] >>submit
|
||||
<auth-boilerplate> ;
|
||||
<auth-boilerplate>
|
||||
<secure-realm-only> ;
|
||||
|
||||
: allow-registration ( login -- login )
|
||||
<register-action> "register" add-responder ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
<url>
|
||||
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
|
||||
[ <a =href a> ] [code] ;
|
||||
|
||||
: a-end-tag ( tag -- )
|
||||
drop [ </a> ] [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 -- )
|
||||
[ <form ] [code]
|
||||
[ compile-attr [ =method ] [code] ]
|
||||
[ compile-attr [ resolve-base-path =action ] [code] ]
|
||||
[ compile-attrs ]
|
||||
tri*
|
||||
[ form> ] [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 [ </form> ] [code] ;
|
||||
|
||||
CHLOE: form
|
||||
{
|
||||
[ compile-link-attrs ]
|
||||
[ form-start-tag ]
|
||||
[ compile-children ]
|
||||
[ form-end-tag ]
|
||||
} cleave ;
|
||||
|
||||
STRING: button-tag-markup
|
||||
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<button type="submit"></button>
|
||||
</t:form>
|
||||
;
|
||||
|
||||
: 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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 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 ] [
|
||||
<url>
|
||||
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 -- )
|
||||
[ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
|
||||
|
||||
CHLOE: a
|
||||
[ a-start-tag ]
|
||||
[ process-tag-children ]
|
||||
[ drop </a> ]
|
||||
tri ;
|
||||
|
||||
: hidden-form-field ( value name -- )
|
||||
over [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 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 -- )
|
||||
[
|
||||
[
|
||||
<form
|
||||
{
|
||||
[ link-attrs ]
|
||||
[ "method" optional-attr "post" or =method ]
|
||||
[ "action" required-attr resolve-base-path =action ]
|
||||
[ attrs>> non-chloe-attrs-only print-attrs ]
|
||||
} cleave
|
||||
form>
|
||||
]
|
||||
[ form-magic ] bi
|
||||
] with-scope ;
|
||||
|
||||
CHLOE: form
|
||||
[ form-start-tag ]
|
||||
[ process-tag-children ]
|
||||
[ drop </form> ]
|
||||
tri ;
|
||||
|
||||
STRING: button-tag-markup
|
||||
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<button type="submit"></button>
|
||||
</t:form>
|
||||
;
|
||||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
|
|
@ -32,10 +32,14 @@ TUPLE: secure-only < filter-responder ;
|
|||
|
||||
C: <secure-only> secure-only
|
||||
|
||||
: if-secure ( quot -- )
|
||||
>r url get protocol>> "http" =
|
||||
[ url get <secure-redirect> ]
|
||||
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 <secure-redirect> ]
|
||||
} cond ; inline
|
||||
|
||||
M: secure-only call-responder*
|
||||
'[ , , call-next-method ] if-secure ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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> 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
|
||||
[ <title> write-title </title> ] [ write-title ] if ;
|
||||
[ <title> write-title </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 <style> write-style </style> ;
|
||||
drop [ <style> write-style </style> ] [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 <file-reader> 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 <file-reader> read-xml process-chloe ;
|
||||
template-quot call ;
|
||||
|
||||
INSTANCE: chloe template
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
"</" [write]
|
||||
name>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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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>> ] [ <mirror> ] 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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } <branch> ;
|
||||
|
||||
METHOD: sift-down { singleton-heap empty-heap }
|
||||
: singleton-sift-down ( value prio singleton empty -- heap )
|
||||
3dup drop prio>> <= [ <branch> ] [
|
||||
drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
|
||||
<singleton-heap> <persistent-heap> <branch>
|
||||
] if ;
|
||||
|
||||
M: empty-heap sift-down
|
||||
over singleton-heap? [ singleton-sift-down ] [ <branch> ] 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
|
||||
<branch> ;
|
||||
|
||||
METHOD: sift-down { branch branch }
|
||||
M: branch sift-down ! both arguments are branches
|
||||
3dup [ prio>> <= ] both-with? [ <branch> ] [
|
||||
2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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\"/></body></html>" ]
|
||||
[ "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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
<t:title><t:label t:name="title" /></t:title>
|
||||
|
||||
<div class="description">
|
||||
<t:farkup t:name="content" />
|
||||
<t:html t:name="html" />
|
||||
</div>
|
||||
|
||||
<p>
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
</t:a>
|
||||
</h2>
|
||||
|
||||
<t:farkup t:name="content" />
|
||||
<t:html t:name="html" />
|
||||
</t:bind>
|
||||
</td>
|
||||
</t:if>
|
||||
|
|
@ -52,7 +52,7 @@
|
|||
<td>
|
||||
<t:bind t:name="footer">
|
||||
<small>
|
||||
<t:farkup t:name="content" />
|
||||
<t:html t:name="html" />
|
||||
</small>
|
||||
</t:bind>
|
||||
</td>
|
||||
|
|
|
|||
|
|
@ -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" {
|
|||
|
||||
: <article> ( 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 ;
|
|||
: <revision> ( 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>> <article> select-tuple
|
||||
[ amend-article ] [ add-article ] if*
|
||||
] bi ;
|
||||
]
|
||||
tri ;
|
||||
|
||||
: <edit-article-action> ( -- action )
|
||||
<page-action>
|
||||
|
|
|
|||
|
|
@ -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 <inet> smtp-server set-global
|
||||
"noreply@concatenative.org" lost-password-from set-global
|
||||
"website@concatenative.org" insomniac-sender set-global
|
||||
|
|
|
|||
Loading…
Reference in New Issue