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 tests
db4
Aaron Schaefer 2008-09-08 03:20:40 -04:00
commit 700ec268c8
30 changed files with 461 additions and 343 deletions

View File

@ -50,7 +50,7 @@ SYMBOL: bootstrap-time
default-image-name "output-image" set-global 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 "" "exclude" set-global
parse-command-line parse-command-line

View File

@ -134,22 +134,21 @@ TUPLE: protected < filter-responder description capabilities ;
swap >>responder ; swap >>responder ;
: have-capabilities? ( capabilities -- ? ) : have-capabilities? ( capabilities -- ? )
logged-in-user get { realm get secure>> secure-connection? not and [ drop f ] [
{ [ dup not ] [ 2drop f ] } logged-in-user get {
{ [ dup deleted>> 1 = ] [ 2drop f ] } { [ dup not ] [ 2drop f ] }
[ capabilities>> subset? ] { [ dup deleted>> 1 = ] [ 2drop f ] }
} cond ; [ capabilities>> subset? ]
} cond
] if ;
M: protected call-responder* ( path responder -- response ) M: protected call-responder* ( path responder -- response )
'[ dup protected set
, , dup capabilities>> have-capabilities?
dup protected set [ call-next-method ] [
dup capabilities>> have-capabilities? [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
[ call-next-method ] [ realm get login-required*
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi* ] if ;
realm get login-required*
] if
] if-secure-realm ;
: <auth-boilerplate> ( responder -- responder' ) : <auth-boilerplate> ( responder -- responder' )
<boilerplate> { realm "boilerplate" } >>template ; <boilerplate> { realm "boilerplate" } >>template ;

View File

@ -36,7 +36,8 @@ IN: furnace.auth.features.registration
URL" $realm" <redirect> URL" $realm" <redirect>
] >>submit ] >>submit
<auth-boilerplate> ; <auth-boilerplate>
<secure-realm-only> ;
: allow-registration ( login -- login ) : allow-registration ( login -- login )
<register-action> "register" add-responder ; <register-action> "register" add-responder ;

View File

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

View File

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

View File

@ -130,7 +130,8 @@ M: conversations call-responder*
over post-data>> >>post-data over post-data>> >>post-data
over url>> >>url over url>> >>url
] change ] change
url>> path>> split-path [ url>> url set ]
[ url>> path>> split-path ] bi
conversations get responder>> call-responder ; conversations get responder>> call-responder ;
\ end-aside-post DEBUG add-input-logging \ end-aside-post DEBUG add-input-logging

View File

@ -1,30 +1,14 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs USING: namespaces assocs sequences kernel classes splitting
continuations namespaces sequences splitting words vocabs.loader accessors strings combinators arrays
vocabs.loader classes strings continuations present fry
fry urls multiline present urls html.elements
xml http http.server http.server.redirection ;
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 ;
IN: furnace IN: furnace
: nested-responders ( -- seq ) : nested-responders ( -- seq )
responder-nesting get a:values ; responder-nesting get values ;
: each-responder ( quot -- ) : each-responder ( quot -- )
nested-responders swap each ; inline nested-responders swap each ; inline
@ -63,10 +47,25 @@ M: url adjust-url
M: string adjust-url ; M: string adjust-url ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
GENERIC: modify-form ( responder -- ) GENERIC: modify-form ( responder -- )
M: object modify-form drop ; 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 ) : request-params ( request -- assoc )
dup method>> { dup method>> {
{ "GET" [ url>> query>> ] } { "GET" [ url>> query>> ] }
@ -110,98 +109,4 @@ SYMBOL: exit-continuation
: with-exit-continuation ( quot -- ) : with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ; '[ exit-continuation set @ ] callcc1 exit-continuation off ;
! Chloe tags "furnace.chloe-tags" require
: 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 ;

View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry USING: kernel accessors combinators namespaces fry
io.servers.connection urls io.servers.connection urls http http.server
http http.server http.server.redirection http.server.filters http.server.redirection http.server.responses
furnace ; http.server.filters furnace ;
IN: furnace.redirection IN: furnace.redirection
: <redirect> ( url -- response ) : <redirect> ( url -- response )
@ -32,10 +32,14 @@ TUPLE: secure-only < filter-responder ;
C: <secure-only> secure-only C: <secure-only> secure-only
: if-secure ( quot -- ) : secure-connection? ( -- ? ) url get protocol>> "https" = ;
>r url get protocol>> "http" =
[ url get <secure-redirect> ] : if-secure ( quot -- response )
r> if ; inline {
{ [ secure-connection? ] [ call ] }
{ [ request get method>> "POST" = ] [ drop <400> ] }
[ drop url get <secure-redirect> ]
} cond ; inline
M: secure-only call-responder* M: secure-only call-responder*
'[ , , call-next-method ] if-secure ; '[ , , call-next-method ] if-secure ;

View File

@ -4,22 +4,7 @@ namespaces xml html.components html.forms
splitting unicode.categories furnace accessors ; splitting unicode.categories furnace accessors ;
IN: html.templates.chloe.tests IN: html.templates.chloe.tests
[ f ] [ f parse-query-attr ] unit-test reset-templates
[ 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
: run-template : run-template
with-string-writer [ "\r\n\t" member? not ] filter with-string-writer [ "\r\n\t" member? not ] filter

View File

@ -1,78 +1,53 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel namespaces USING: accessors kernel sequences combinators kernel fry
classes.tuple assocs splitting words arrays memoize namespaces classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string io io.files io.encodings.utf8 io.streams.string unicode.case
unicode.case mirrors fry math urls present mirrors math urls present multiline quotations xml xml.data
multiline xml xml.data xml.writer xml.utilities
html.forms html.forms
html.elements html.elements
html.components html.components
html.templates html.templates
html.templates.chloe.compiler
html.templates.chloe.components
html.templates.chloe.syntax ; html.templates.chloe.syntax ;
IN: html.templates.chloe IN: html.templates.chloe
! Chloe is Ed's favorite web designer ! Chloe is Ed's favorite web designer
SYMBOL: tag-stack
TUPLE: chloe path ; TUPLE: chloe path ;
C: <chloe> chloe C: <chloe> chloe
DEFER: process-template CHLOE: chloe compile-children ;
: chloe-attrs-only ( assoc -- assoc' ) CHLOE: title compile-children>string [ set-title ] [code] ;
[ 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: write-title CHLOE: write-title
drop drop
"head" tag-stack get member? "head" tag-stack get member?
"title" tag-stack get member? not and "title" tag-stack get member? not and
[ <title> write-title </title> ] [ write-title ] if ; [ <title> write-title </title> ] [ write-title ] ? [code] ;
CHLOE: style CHLOE: style
dup "include" optional-attr dup [ dup "include" optional-attr [
swap children>string empty? [ utf8 file-contents [ add-style ] [code-with]
"style tag cannot have both an include attribute and a body" throw
] unless
utf8 file-contents
] [ ] [
drop children>string compile-children>string [ add-style ] [code]
] if add-style ; ] ?if ;
CHLOE: write-style 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 -- ) : (bind-tag) ( tag quot -- )
[ [
[ "name" required-attr ] keep [ "name" required-attr compile-attr ] keep
'[ , process-tag-children ] ] dip process-children ; inline
] dip call ; inline
CHLOE: each [ with-each-value ] (bind-tag) ; 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) ; CHLOE: bind [ with-form ] (bind-tag) ;
: error-message-tag ( tag -- )
children>string render-error ;
CHLOE: comment drop ; 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 ) : attr>word ( value -- word/f )
":" split1 swap lookup ; ":" split1 swap lookup ;
: if-satisfied? ( tag -- ? ) : if>quot ( tag -- quot )
[ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ] [
[ "value" optional-attr [ value ] [ t ] if* ] [ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ]
bi and ; [ "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: label
CHLOE-SINGLETON: link CHLOE-SINGLETON: link
@ -112,51 +88,13 @@ CHLOE-TUPLE: choice
CHLOE-TUPLE: checkbox CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code CHLOE-TUPLE: code
: process-chloe-tag ( tag -- ) MEMO: template-quot ( chloe -- quot )
dup main>> dup tags get at path>> ".xml" append utf8 <file-reader> read-xml
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ; compile-template ;
: process-tag ( tag -- ) : reset-templates ( -- ) \ template-quot reset-memoized ;
{
[ 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 ;
M: chloe call-template* M: chloe call-template*
path>> ".xml" append utf8 <file-reader> read-xml process-chloe ; template-quot call ;
INSTANCE: chloe template INSTANCE: chloe template

View File

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

View File

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

View File

@ -21,7 +21,7 @@ tags global [ H{ } clone or ] change-at
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline : chloe-ns "http://factorcode.org/chloe/1.0" ; inline
MEMO: chloe-name ( string -- name ) : chloe-name ( string -- name )
name new name new
swap >>main swap >>main
chloe-ns >>url ; chloe-ns >>url ;
@ -32,30 +32,3 @@ MEMO: chloe-name ( string -- name )
: optional-attr ( tag name -- value ) : optional-attr ( tag name -- value )
chloe-name swap at ; 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

View File

@ -113,7 +113,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
{ [ dup real? ] [ number>string ] } { [ dup real? ] [ number>string ] }
[ ] [ ]
} cond } cond
check-cookie-string "=" swap check-cookie-string 3append , [ check-cookie-string ] bi@ "=" swap 3append ,
] ]
} case ; } case ;

View File

@ -73,7 +73,7 @@ M: threaded-server handle-client* handler>> call ;
] with-stream ; ] with-stream ;
: thread-name ( server-name addrspec -- string ) : thread-name ( server-name addrspec -- string )
unparse " connection from " swap 3append ; unparse-short " connection from " swap 3append ;
: accept-connection ( threaded-server -- ) : accept-connection ( threaded-server -- )
[ accept ] [ addr>> ] bi [ accept ] [ addr>> ] bi

View File

@ -1,4 +1,4 @@
USING: kernel accessors multi-methods locals combinators math arrays USING: kernel accessors locals combinators math arrays
assocs namespaces sequences ; assocs namespaces sequences ;
IN: persistent.heaps IN: persistent.heaps
! These are minheaps ! These are minheaps
@ -36,14 +36,15 @@ PRIVATE>
GENERIC: sift-down ( value prio left right -- heap ) GENERIC: sift-down ( value prio left right -- heap )
METHOD: sift-down { empty-heap empty-heap } <branch> ; : singleton-sift-down ( value prio singleton empty -- heap )
METHOD: sift-down { singleton-heap empty-heap }
3dup drop prio>> <= [ <branch> ] [ 3dup drop prio>> <= [ <branch> ] [
drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
<singleton-heap> <persistent-heap> <branch> <singleton-heap> <persistent-heap> <branch>
] if ; ] if ;
M: empty-heap sift-down
over singleton-heap? [ singleton-sift-down ] [ <branch> ] if ;
:: reroot-left ( value prio left right -- heap ) :: reroot-left ( value prio left right -- heap )
left value>> left prio>> left value>> left prio>>
value prio left left>> left right>> sift-down 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 value prio right left>> right right>> sift-down
<branch> ; <branch> ;
METHOD: sift-down { branch branch } M: branch sift-down ! both arguments are branches
3dup [ prio>> <= ] both-with? [ <branch> ] [ 3dup [ prio>> <= ] both-with? [ <branch> ] [
2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if 2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
] if ; ] if ;

View File

@ -42,9 +42,9 @@ IN: tools.deploy.backend
: bootstrap-profile ( -- profile ) : bootstrap-profile ( -- profile )
{ {
{ "threads" deploy-threads? }
{ "math" deploy-math? } { "math" deploy-math? }
{ "compiler" deploy-compiler? } { "compiler" deploy-compiler? }
{ "threads" deploy-threads? }
{ "ui" deploy-ui? } { "ui" deploy-ui? }
{ "random" deploy-random? } { "random" deploy-random? }
} [ nip get ] assoc-filter keys } [ nip get ] assoc-filter keys

View File

@ -26,7 +26,7 @@ namespaces continuations layouts accessors ;
[ t ] [ 1300000 small-enough? ] unit-test [ t ] [ 1300000 small-enough? ] unit-test
[ "staging.threads-math-compiler-ui-strip.image" ] [ [ "staging.math-compiler-threads-ui-strip.image" ] [
"hello-ui" deploy-config "hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind [ bootstrap-profile staging-image-name file-name ] bind
] unit-test ] unit-test
@ -39,9 +39,9 @@ namespaces continuations layouts accessors ;
! !
! [ t ] [ 1500000 small-enough? ] unit-test ! [ t ] [ 1500000 small-enough? ] unit-test
! !
! [ ] [ "bunny" shake-and-bake ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test
!
! [ t ] [ 2500000 small-enough? ] unit-test [ t ] [ 2500000 small-enough? ] unit-test
{ {
"tools.deploy.test.1" "tools.deploy.test.1"

View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ; USING: tools.deploy.config ;
H{ 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-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f } { deploy-ui? f }
{ deploy-word-props? f } { deploy-word-props? f }
{ deploy-word-defs? 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 }
} }

View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ; USING: tools.deploy.config ;
H{ H{
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-threads? t } { deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? 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-name "tools.deploy.test.2" }
{ deploy-compiler? t } { deploy-compiler? t }
{ deploy-word-props? f } { deploy-reflection 1 }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t } { "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
} }

View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ; USING: tools.deploy.config ;
H{ H{
{ deploy-io 3 }
{ deploy-ui? f }
{ deploy-threads? t } { deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? 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-name "tools.deploy.test.3" }
{ deploy-compiler? t } { deploy-compiler? t }
{ deploy-word-props? f } { deploy-reflection 1 }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t } { "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
} }

View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ; USING: tools.deploy.config ;
H{ H{
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-threads? t } { deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? 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-name "tools.deploy.test.4" }
{ deploy-compiler? t } { deploy-compiler? t }
{ deploy-word-props? f } { deploy-reflection 1 }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t } { "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
} }

View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ; USING: tools.deploy.config ;
H{ H{
{ deploy-io 3 }
{ deploy-ui? f }
{ deploy-threads? t } { deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? 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-name "tools.deploy.test.5" }
{ deploy-compiler? t } { deploy-compiler? t }
{ deploy-word-props? f } { deploy-reflection 1 }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t } { "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
} }

View File

@ -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\"/></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

View File

@ -37,10 +37,11 @@ SYMBOL: indenter
[ [ empty? ] [ string? ] bi and not ] filter [ [ empty? ] [ string? ] bi and not ] filter
] when ; ] when ;
: name>string ( name -- string )
[ main>> ] [ space>> ] bi [ ":" swap 3append ] unless-empty ;
: print-name ( name -- ) : print-name ( name -- )
dup space>> f like name>string write ;
[ write CHAR: : write1 ] when*
main>> write ;
: print-attrs ( assoc -- ) : print-attrs ( assoc -- )
[ [

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! 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 ; combinators.lib math fry accessors lists combinators.short-circuit ;
IN: lisp.parser IN: lisp.parser

View File

@ -5,7 +5,7 @@
<t:title><t:label t:name="title" /></t:title> <t:title><t:label t:name="title" /></t:title>
<div class="description"> <div class="description">
<t:farkup t:name="content" /> <t:html t:name="html" />
</div> </div>
<p> <p>

View File

@ -41,7 +41,7 @@
</t:a> </t:a>
</h2> </h2>
<t:farkup t:name="content" /> <t:html t:name="html" />
</t:bind> </t:bind>
</td> </td>
</t:if> </t:if>
@ -52,7 +52,7 @@
<td> <td>
<t:bind t:name="footer"> <t:bind t:name="footer">
<small> <small>
<t:farkup t:name="content" /> <t:html t:name="html" />
</small> </small>
</t:bind> </t:bind>
</td> </td>

View File

@ -3,7 +3,7 @@
USING: accessors kernel hashtables calendar random assocs USING: accessors kernel hashtables calendar random assocs
namespaces splitting sequences sorting math.order present namespaces splitting sequences sorting math.order present
io.files io.encodings.ascii io.files io.encodings.ascii
syndication syndication farkup
html.components html.forms html.components html.forms
http.server http.server
http.server.dispatchers http.server.dispatchers
@ -47,7 +47,7 @@ article "ARTICLES" {
: <article> ( title -- article ) article new swap >>title ; : <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" { revision "REVISIONS" {
{ "id" "ID" INTEGER +db-assigned-id+ } { "id" "ID" INTEGER +db-assigned-id+ }
@ -55,6 +55,7 @@ revision "REVISIONS" {
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
{ "date" "DATE" TIMESTAMP +not-null+ } { "date" "DATE" TIMESTAMP +not-null+ }
{ "content" "CONTENT" TEXT +not-null+ } { "content" "CONTENT" TEXT +not-null+ }
{ "html" "HTML" TEXT +not-null+ } ! Farkup converted to HTML
{ "description" "DESCRIPTION" TEXT } { "description" "DESCRIPTION" TEXT }
} define-persistent } define-persistent
@ -71,6 +72,9 @@ M: revision feed-entry-url id>> revision-url ;
: <revision> ( id -- revision ) : <revision> ( id -- revision )
revision new swap >>id ; revision new swap >>id ;
: compute-html ( revision -- )
dup content>> convert-farkup >>html drop ;
: validate-title ( -- ) : validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ; { { "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 ; [ title>> ] [ id>> ] bi article boa insert-tuple ;
: add-revision ( revision -- ) : add-revision ( revision -- )
[ compute-html ]
[ insert-tuple ] [ insert-tuple ]
[ [
dup title>> <article> select-tuple dup title>> <article> select-tuple
[ amend-article ] [ add-article ] if* [ amend-article ] [ add-article ] if*
] bi ; ]
tri ;
: <edit-article-action> ( -- action ) : <edit-article-action> ( -- action )
<page-action> <page-action>

View File

@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets
io.sockets.secure io.servers.connection io.sockets.secure io.servers.connection
namespaces db db.tuples db.sqlite smtp urls namespaces db db.tuples db.sqlite smtp urls
logging.insomniac logging.insomniac
html.templates.chloe
http.server http.server
http.server.dispatchers http.server.dispatchers
http.server.redirection http.server.redirection
@ -68,6 +69,7 @@ SYMBOL: key-file
SYMBOL: dh-file SYMBOL: dh-file
: common-configuration ( -- ) : common-configuration ( -- )
reset-templates
"concatenative.org" 25 <inet> smtp-server set-global "concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global "noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global "website@concatenative.org" insomniac-sender set-global