steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
parent fe24f3e82a 1bcb041561
commit 700ec268c8
30 changed files with 461 additions and 343 deletions

2
basis/bootstrap/stage2.factor
View File

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

27
basis/furnace/auth/auth.factor
View File

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

3
basis/furnace/auth/features/registration/registration.factor
View File

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

19
basis/furnace/chloe-tags/chloe-tags-tests.factor Normal file
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

121
basis/furnace/chloe-tags/chloe-tags.factor Normal file
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 ;

3
basis/furnace/conversations/conversations.factor
View File

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

141
basis/furnace/furnace.factor
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.
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

18
basis/furnace/redirection/redirection.factor
View File

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

17
basis/html/templates/chloe/chloe-tests.factor
View File

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

132
basis/html/templates/chloe/chloe.factor
View File

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

127
basis/html/templates/chloe/compiler/compiler.factor Normal file
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 ;

35
basis/html/templates/chloe/components/components.factor Normal file
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

29
basis/html/templates/chloe/syntax/syntax.factor
View File

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

2
basis/http/http.factor
View File

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

2
basis/io/servers/connection/connection.factor
View File

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

11
basis/persistent/heaps/heaps.factor
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 ;
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 ;

2
basis/tools/deploy/backend/backend.factor
View File

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

8
basis/tools/deploy/deploy-tests.factor
View File

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

16
basis/tools/deploy/test/1/deploy.factor
View File

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

14
basis/tools/deploy/test/2/deploy.factor
View File

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

14
basis/tools/deploy/test/3/deploy.factor
View File

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

14
basis/tools/deploy/test/4/deploy.factor
View File

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

14
basis/tools/deploy/test/5/deploy.factor
View File

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

4
basis/xml/generator/generator-tests.factor
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" } } 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

7
basis/xml/writer/writer.factor
View File

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

2
extra/lisp/parser/parser.factor
View File

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

2
extra/webapps/wiki/view.xml
View File

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

4
extra/webapps/wiki/wiki-common.xml
View File

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

12
extra/webapps/wiki/wiki.factor
View File

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

2
extra/websites/concatenative/concatenative.factor
View File

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