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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-09-08 09:24:35 -05:00
parent e257291883 24b42d4008
commit 573ec9ce68
41 changed files with 624 additions and 400 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

51
basis/farkup/farkup-docs.factor
View File

@ -1,6 +1,51 @@
USING: help.markup help.syntax ;
USING: help.markup help.syntax strings io ;
IN: farkup
HELP: convert-farkup
{ $values { "string" "a string" } { "string'" "a string" } }
{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ;
{ $values { "string" string } { "string'" string } }
{ $description "Parse a Farkup string and convert it to an HTML string." } ;
HELP: write-farkup
{ $values { "string" string } }
{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
HELP: farkup ( string -- farkup )
{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
HELP: (write-farkup)
{ $values { "farkup" "a Farkup syntax tree node" } }
{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
{ $subsection heading1 }
{ $subsection heading2 }
{ $subsection heading3 }
{ $subsection heading4 }
{ $subsection strong }
{ $subsection emphasis }
{ $subsection superscript }
{ $subsection subscript }
{ $subsection inline-code }
{ $subsection paragraph }
{ $subsection list-item }
{ $subsection list }
{ $subsection table }
{ $subsection table-row }
{ $subsection link }
{ $subsection image }
{ $subsection code } ;
ARTICLE: "farkup" "Farkup"
"The " { $vocab-link "farkup" } " vocabulary implements Farkup (Factor mARKUP), a simple markup language. Farkup was loosely based on the markup languages employed by MediaWiki and " { $url "http://reddit.com" } "."
$nl
"The main entry points for converting Farkup to HTML:"
{ $subsection convert-farkup }
{ $subsection write-farkup }
"The syntax tree of a piece of Farkup can also be inspected and modified:"
{ $subsection farkup }
{ $subsection (write-farkup) }
{ $subsection "farkup-ast" } ;
ABOUT: "farkup"

18
basis/farkup/farkup-tests.factor
View File

@ -1,8 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test ;
USING: farkup kernel peg peg.ebnf tools.test namespaces ;
IN: farkup.tests
[ "Baz" ] [ "Foo/Bar/Baz" simple-link-title ] unit-test
[ "Baz" ] [ "Baz" simple-link-title ] unit-test
[ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23"
"paragraph" \ farkup rule parse drop
@ -81,10 +84,15 @@ IN: farkup.tests
[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
[ "<p><img src='lol.jpg'/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src='lol.jpg' alt='teh lol'/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href='http://lol.com'>http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
[ "<p><a href='http://lol.com'>haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
[ "<p><a href='Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
"/wiki/view/" relative-link-prefix [
[ "<p><a href='/wiki/view/Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
] with-variable
[ ] [ "[{}]" convert-farkup drop ] unit-test

80
basis/farkup/farkup.factor
View File

@ -28,6 +28,12 @@ TUPLE: link href text ;
TUPLE: image href text ;
TUPLE: code mode string ;
: absolute-url? ( string -- ? )
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
: simple-link-title ( string -- string' )
dup absolute-url? [ "/" last-split1 swap or ] unless ;
EBNF: farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl
@ -67,7 +73,7 @@ image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]"
=> [[ second >string f image boa ]]
simple-link = "[[" (!("|]" | "]]") .)+ "]]"
=> [[ second >string dup link boa ]]
=> [[ second >string dup simple-link-title link boa ]]
labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
=> [[ [ second >string ] [ fourth >string ] bi link boa ]]
@ -119,31 +125,26 @@ stand-alone
{ [ dup empty? ] [ drop invalid-url ] }
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
[ drop invalid-url ] unless
] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
[ relative-link-prefix get prepend ]
} cond ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
: write-link ( text href -- )
: write-link ( href text -- )
escape-link
"<a" write
" href=\"" write write "\"" write
link-no-follow? get [ " nofollow=\"true\"" write ] when
">" write write "</a>" write ;
[ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
[ write </a> ]
bi* ;
: write-image-link ( href text -- )
disable-images? get [
2drop "<strong>Images are not allowed</strong>" write
2drop
<strong> "Images are not allowed" write </strong>
] [
escape-link
>r "<img src=\"" write write "\"" write r>
[ " alt=\"" write write "\"" write ] unless-empty
"/>" write
[ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
] if ;
: render-code ( string mode -- string' )
@ -154,32 +155,35 @@ stand-alone
</pre>
] with-string-writer write ;
GENERIC: write-farkup ( obj -- )
GENERIC: (write-farkup) ( farkup -- )
: <foo.> ( string -- ) <foo> write ;
: </foo.> ( string -- ) </foo> write ;
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
M: table-row write-farkup ( obj -- )
obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
M: fixnum write-farkup ( obj -- ) write1 ;
M: string write-farkup ( obj -- ) write ;
M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
M: f write-farkup ( obj -- ) drop ;
M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
M: table-row (write-farkup) ( obj -- )
obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
M: fixnum (write-farkup) ( obj -- ) write1 ;
M: string (write-farkup) ( obj -- ) write ;
M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
M: f (write-farkup) ( obj -- ) drop ;
: write-farkup ( string -- )
farkup (write-farkup) ;
: convert-farkup ( string -- string' )
farkup [ write-farkup ] with-string-writer ;
farkup [ (write-farkup) ] with-string-writer ;

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

126
basis/furnace/chloe-tags/chloe-tags.factor Normal file
View File

@ -0,0 +1,126 @@
! 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-with-scope ;
: 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
] compile-with-scope ;
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 ;

2
basis/html/components/components.factor
View File

@ -156,7 +156,7 @@ M: farkup render*
[
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
[ disable-images>> [ string>boolean disable-images? set ] when* ] bi
drop string-lines "\n" join convert-farkup write
drop string-lines "\n" join write-farkup
] with-scope ;
! Inspector component

3
basis/html/elements/elements.factor
View File

@ -142,6 +142,7 @@ SYMBOL: html
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style" "input"
"strong"
] [ define-closed-html-word ] each
! Define some open HTML tags
@ -160,6 +161,8 @@ SYMBOL: html
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple" "checked"
"summary" "cellspacing" "align" "scope" "abbr"
"nofollow" "alt"
] [ define-attribute-word ] each
>>

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

136
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,21 @@ 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 ;
: read-template ( chloe -- xml )
path>> ".xml" append utf8 <file-reader> read-xml ;
: process-tag ( tag -- )
{
[ main>> >lower tag-stack get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
[ drop tag-stack get pop* ]
} cleave ;
MEMO: template-quot ( chloe -- quot )
read-template compile-template ;
: expand-attrs ( tag -- tag )
dup [ tag? ] [ xml? ] bi or [
clone [
[ "@" ?head [ value present ] when ] assoc-map
] change-attrs
] when ;
MEMO: nested-template-quot ( chloe -- quot )
read-template compile-nested-template ;
: 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 nested-template-quot } [ reset-memoized ] each ;
M: chloe call-template*
path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
nested-template? get
[ nested-template-quot ] [ template-quot ] if
assert-depth ;
INSTANCE: chloe template

131
basis/html/templates/chloe/compiler/compiler.factor Normal file
View File

@ -0,0 +1,131 @@
! 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 present 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 present write ] [code-with] ;
: compile-attr ( value -- )
reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
: 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 ;
: compile-quot ( quot -- )
reset-buffer
[
SBUF" " string-buffer set
call
reset-buffer
] [ ] make , ; inline
: process-children ( tag quot -- )
[ [ compile-children ] compile-quot ] [ % ] bi* ; inline
: compile-children>string ( tag -- )
[ with-string-writer ] process-children ;
: compile-with-scope ( quot -- )
compile-quot [ with-scope ] [code] ; inline
: 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

14
basis/locals/locals-tests.factor
View File

@ -316,3 +316,17 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
! [ f ] [ 3 wlet-&&-test ] unit-test
! [ f ] [ 8 wlet-&&-test ] unit-test
! [ t ] [ 12 wlet-&&-test ] unit-test
[ { 10 } ] [ 10 [| a | { a } ] call ] unit-test
[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
[ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
[ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
[ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
[ H{ { 10 "a" } { 20 "b" } { 30 "c" } } ]
[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
[ T{ slice f 0 3 "abc" } ]
[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test

1
basis/logging/logging.factor
View File

@ -46,6 +46,7 @@ SYMBOL: log-service
dup array? [ dup length 1 = [ first ] when ] when
dup string? [
[
boa-tuples? on
string-limit? off
1 line-limit set
3 nesting-limit set

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

5
basis/xml/writer/writer-tests.factor Normal file
View File

@ -0,0 +1,5 @@
IN: xml.writer.tests
USING: xml.data xml.writer tools.test ;
[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] 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 [ ":" rot 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/initial-content/Farkup.txt
View File

@ -34,7 +34,7 @@ CAN HAS STDIO?
VISIBLE "HAI WORLD!"
KTHXBYE}]
There is syntax highlighting various languages, too:
There is syntax highlighting for various languages, too:
[factor{PEG: parse-request-line ( string -- triple )
#! Triple is { method url version }

4
extra/webapps/wiki/initial-content/Front Page.txt
View File

@ -1,5 +1,3 @@
Congratulations, you are now running your very own Wiki.
You can now click *Edit* below and begin editing the content of the [[Front Page]]. This Wiki uses [[Farkup]] to mark up text.
Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
You can now click *Edit* below and begin editing the content of the [[Front Page]]. More information at [[Wiki Help]].

5
extra/webapps/wiki/initial-content/Wiki Help.txt Normal file
View File

@ -0,0 +1,5 @@
This Wiki uses [[Farkup]] to mark up text.
Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
The Wiki supports hierarchical article organization. You can separate components in article names with slashes, and Wiki links only display the last component. An example: [[Factor/Features]].

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>

34
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 ;
@ -89,6 +93,9 @@ M: revision feed-entry-url id>> revision-url ;
<article> select-tuple
dup [ revision>> <revision> select-tuple ] when ;
: init-relative-link-prefix ( -- )
URL" $wiki/view/" adjust-url present relative-link-prefix set ;
: <view-article-action> ( -- action )
<action>
@ -96,6 +103,7 @@ M: revision feed-entry-url id>> revision-url ;
[
validate-title
init-relative-link-prefix
] >>init
[
@ -118,7 +126,7 @@ M: revision feed-entry-url id>> revision-url ;
validate-integer-id
"id" value <revision>
select-tuple from-object
URL" $wiki/view/" adjust-url present relative-link-prefix set
init-relative-link-prefix
] >>init
{ wiki "view" } >>template
@ -140,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>
@ -370,11 +380,13 @@ M: revision feed-entry-url id>> revision-url ;
: init-wiki ( -- )
"resource:extra/webapps/wiki/initial-content" directory* keys
[
[ ascii file-contents ] [ file-name "." split1 drop ] bi
f <revision>
swap >>title
swap >>content
"slava" >>author
now >>date
add-revision
dup file-name ".txt" ?tail [
swap ascii file-contents
f <revision>
swap >>content
swap >>title
"slava" >>author
now >>date
add-revision
] [ 2drop ] if
] each ;

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