2 over set-length
>array
] unit-test
+
+[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
M: clumps group@
[ n>> over + ] [ seq>> ] bi ;
-TUPLE: sliced-clumps < groups ;
+TUPLE: sliced-clumps < clumps ;
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline
{ $subsection parse-tokens } ;
ARTICLE: "parsing-words" "Parsing words"
-"The Factor parser is follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
+"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
$nl
"Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:"
{ $code ": hello \"Hello world\" print ; parsing" }
-"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
+"Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser."
+$nl
+"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
+$nl
+"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later."
$nl
"Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:"
-{ $link staging-violation }
+{ $subsection staging-violation }
"Tools for implementing parsing words:"
{ $subsection "reading-ahead" }
{ $subsection "parsing-word-nest" }
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
-CHLOE: atom
- [ children>string ]
- [ "href" required-attr ]
- [ "query" optional-attr parse-query-attr ] tri
- <url>
- swap >>query
- swap >>path
- adjust-url relative-to-request
- add-atom-feed ;
+: a-url-path ( tag -- string )
+ [ "href" required-attr ] [ "rest" optional-attr value ] bi
+ [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
+
+: a-url ( tag -- url )
+ dup "value" optional-attr [ ] [
+ <url>
+ swap
+ [ a-url-path >>path ]
+ [ "query" optional-attr parse-query-attr >>query ]
+ bi
+ ] ?if
+ adjust-url relative-to-request ;
+
+CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
CHLOE: write-atom drop write-atom-feeds ;
M: object link-attr 2drop ;
: link-attrs ( tag -- )
+ #! Side-effects current namespace.
'[ , _ link-attr ] each-responder ;
: a-start-tag ( tag -- )
- [
- <a
- dup link-attrs
- dup "value" optional-attr [ value f ] [
- [ "href" required-attr ]
- [ "query" optional-attr parse-query-attr ]
- bi
- ] ?if
- <url>
- swap >>query
- swap >>path
- adjust-url relative-to-request =href
- a>
- ] with-scope ;
+ [ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
CHLOE: a
[ a-start-tag ]
[
[
<form
- "POST" =method
- [ link-attrs ]
- [ "action" required-attr resolve-base-path =action ]
- [ tag-attrs non-chloe-attrs-only print-attrs ]
- tri
+ {
+ [ link-attrs ]
+ [ "method" optional-attr "post" or =method ]
+ [ "action" required-attr resolve-base-path =action ]
+ [ tag-attrs non-chloe-attrs-only print-attrs ]
+ } cleave
form>
]
[ form-magic ] bi
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
-POST http://foo/bar HTTP/1.1
+POST /bar HTTP/1.1
Some-Header: 1
Some-Header: 2
Content-Length: 4
[
TUPLE{ request
- url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
+ url: TUPLE{ url path: "/bar" }
method: "POST"
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
] unit-test
STRING: read-request-test-2
-HEAD http://foo/bar HTTP/1.1
+HEAD /bar HTTP/1.1
Host: www.sex.com
;
[
TUPLE{ request
- url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
+ url: TUPLE{ url host: "www.sex.com" path: "/bar" }
method: "HEAD"
version: "1.1"
header: H{ { "host" "www.sex.com" } }
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
-io io.server io.sockets.secure
-io.encodings.iana io.encodings.binary io.encodings.8-bit
+io io.encodings.iana io.encodings.binary io.encodings.8-bit
unicode.case unicode.categories qualified
request new
"1.1" >>version
<url>
- "http" >>protocol
H{ } clone >>query
>>url
H{ } clone >>header
: extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi*
- ensure-port
drop ;
: extract-cookies ( request -- request )
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
-: detect-protocol ( request -- request )
- dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
-
: read-request ( -- request )
<request>
read-method
read-request-version
read-request-header
read-post-data
- detect-protocol
extract-host
extract-cookies ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
-tools.vocabs math
+combinators tools.vocabs math
io
io.server
+io.sockets
+io.sockets.secure
io.encodings
io.encodings.utf8
io.encodings.ascii
io.encodings.binary
io.streams.limited
io.timeouts
-fry logging calendar
+fry logging calendar urls
http
http.server.responses
html.elements
: dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ;
+: prepare-request ( request -- request )
+ [
+ local-address get
+ [ secure? "https" "http" ? >>protocol ]
+ [ port>> '[ , or ] change-port ]
+ bi
+ ] change-url ;
+
+: valid-request? ( request -- ? )
+ url>> port>> local-address get port>> = ;
+
: do-request ( request -- response )
'[
,
- [ init-request ]
- [ log-request ]
- [ dispatch-request ] tri
+ {
+ [ init-request ]
+ [ prepare-request ]
+ [ log-request ]
+ [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
+ } cleave
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- )
dup check-disposed
dup expired>> expired? [
ALIEN: 31337 >>expired
- connections>> [ delete-all ] [ dispose-each ] bi
+ connections>> delete-all
] [ drop ] if ;
: <pool> ( class -- pool )
dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn )
+ dup check-pool
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;
io.streams.duplex logging continuations destructors kernel math
math.parser namespaces parser sequences strings prettyprint
debugger quotations calendar threads concurrency.combinators
-assocs fry ;
+assocs fry accessors ;
IN: io.server
SYMBOL: servers
LOG: accepted-connection NOTICE
-: with-connection ( client remote quot -- )
+: with-connection ( client remote local quot -- )
'[
, [ remote-address set ] [ accepted-connection ] bi
+ , local-address set
@
] with-stream ; inline
: accept-loop ( server quot -- )
[
- >r accept r> '[ , , , with-connection ] "Client" spawn drop
+ [ [ accept ] [ addr>> ] bi ] dip
+ '[ , , , , with-connection ] "Client" spawn drop
] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- )
: datagram-loop ( quot datagram -- )
[
- [ receive dup received-datagram >r swap call r> ] keep
+ [ receive dup received-datagram [ swap call ] dip ] keep
pick [ send ] [ 3drop ] if
] 2keep datagram-loop ; inline
: <edit-post-action> ( -- action )
<page-action>
+ "id" >>rest
+
[
validate-integer-id
"id" value <post> select-tuple from-object
<div class="posting-footer">
Post by
- <t:a t:href="$blogs/" t:query="author">
+ <t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
- <t:a t:href="$blogs/post" t:for="id">View Post</t:a>
+ <t:a t:href="$blogs/post" t:rest="id">View Post</t:a>
|
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
</div>
<t:bind-each t:name="posts">
<h2 class="post-title">
- <t:a t:href="$blogs/post" t:query="id">
+ <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="title" />
</t:a>
</h2>
<div class="posting-footer">
Post by
- <t:a t:href="$blogs/by" t:query="author">
+ <t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
- <t:a t:href="$blogs/post" t:query="id">
+ <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="comments" />
comments.
</t:a>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:href="$blogs/by" t:query="author">
+ <t:atom t:href="$blogs/by" t:rest="author">
Recent Posts by <t:label t:name="author" />
</t:atom>
<t:bind-each t:name="posts">
<h2 class="post-title">
- <t:a t:href="$blogs/post" t:query="id">
+ <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="title" />
</t:a>
</h2>
<div class="posting-footer">
Post by
- <t:a t:href="$blogs/by" t:query="author">
+ <t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
- <t:a t:href="$blogs/post" t:query="id">
+ <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="comments" />
comments.
</t:a>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:href="$blogs/post.atom" t:query="id">
+ <t:atom t:href="$blogs/post.atom" t:rest="id">
<t:label t:name="author" />: <t:label t:name="title" />
</t:atom>
- <t:atom t:href="$blogs/by.atom" t:query="author">
+ <t:atom t:href="$blogs/by.atom" t:rest="author">
Recent Posts by <t:label t:name="author" />
</t:atom>
<div class="posting-footer">
Post by
- <t:a t:href="$blogs/" t:query="author">
+ <t:a t:href="$blogs/" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
- <t:a t:href="$blogs/edit-post" t:query="id">Edit Post</t:a>
+ <t:a t:href="$blogs/edit-post" t:rest="id">Edit Post</t:a>
|
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
</div>
<ul>
<t:bind-each t:name="articles">
<li>
- <t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
+ <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title"/></t:a>
</li>
</t:bind-each>
</ul>
<t:title>Recent Changes</t:title>
- <ul>
- <t:bind-each t:name="changes">
- <li>
- <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
- on
- <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
- by
- <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
- </li>
- </t:bind-each>
- </ul>
+ <div class="revisions">
+
+ <table>
+
+ <tr>
+ <th>Article</th>
+ <th>Date</th>
+ <th>By</th>
+ </tr>
+
+ <t:bind-each t:name="changes">
+ <tr>
+ <td><t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a></td>
+ <td><t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a></td>
+ <td><t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a></td>
+ </tr>
+ </t:bind-each>
+
+ </table>
+
+ </div>
</t:chloe>
<tr>
<th class="field-label">Old revision:</th>
<t:bind t:name="old">
- <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
</t:bind>
</tr>
<tr>
<th class="field-label">New revision:</th>
<t:bind t:name="old">
- <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
</t:bind>
</tr>
</table>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:href="$wiki/revisions.atom" t:query="title">
+ <t:atom t:href="$wiki/revisions.atom" t:rest="title">
Revisions of <t:label t:name="title" />
</t:atom>
<t:call-next-template />
<div class="navbar">
- <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
- | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
- | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+ <t:a t:href="$wiki/view" t:rest="title">Latest</t:a>
+ | <t:a t:href="$wiki/revisions" t:rest="title">Revisions</t:a>
+ | <t:a t:href="$wiki/edit" t:rest="title">Edit</t:a>
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
</div>
<table>
<tr>
<th>Revision</th>
- <th>Author</th>
+ <th>By</th>
<th>Rollback</th>
</tr>
<t:bind-each t:name="revisions">
<tr>
- <td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
- <td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
+ <td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
+ <td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
</tr>
</t:bind-each>
<h2>View Differences</h2>
- <form action="diff" method="get">
+ <t:form t:action="$wiki/diff" t:method="get">
<table>
<tr>
<th class="field-label">Old revision:</th>
</table>
<input type="submit" value="View" />
- </form>
+ </t:form>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:href="$wiki/user-edits.atom" t:query="author">
+ <t:atom t:href="$wiki/user-edits.atom" t:rest="author">
Edits by <t:label t:name="author" />
</t:atom>
<ul>
<t:bind-each t:name="user-edits">
<li>
- <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
+ <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a>
on
- <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+ <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a>
</li>
</t:bind-each>
</ul>
<t:farkup t:name="content" />
</div>
- <p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</em></p>
+ <p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</em></p>
</t:chloe>
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar
-namespaces splitting sequences sorting math.order
+namespaces splitting sequences sorting math.order present
html.components syndication
http.server
http.server.dispatchers
db.types db.tuples lcs farkup urls ;
IN: webapps.wiki
-: view-url ( title -- url )
- "$wiki/view/" prepend >url ;
+: wiki-url ( rest path -- url )
+ [ "$wiki/" % % "/" % % ] "" make
+ <url> swap >>path ;
-: edit-url ( title -- url )
- "$wiki/edit" >url swap "title" set-query-param ;
+: view-url ( title -- url ) "view" wiki-url ;
-: revisions-url ( title -- url )
- "$wiki/revisions" >url swap "title" set-query-param ;
+: edit-url ( title -- url ) "edit" wiki-url ;
-: revision-url ( id -- url )
- "$wiki/revision" >url swap "id" set-query-param ;
+: revisions-url ( title -- url ) "revisions" wiki-url ;
-: user-edits-url ( author -- url )
- "$wiki/user-edits" >url swap "author" set-query-param ;
+: revision-url ( id -- url ) "revision" wiki-url ;
+
+: user-edits-url ( author -- url ) "user-edits" wiki-url ;
TUPLE: wiki < dispatcher ;
: <view-article-action> ( -- action )
<action>
"title" >>rest
-
[
validate-title
- "view?title=" relative-link-prefix set
] >>init
-
[
"title" value dup <article> select-tuple [
revision>> <revision> select-tuple from-object
: <view-revision-action> ( -- action )
<page-action>
+ "id" >>rest
[
validate-integer-id
"id" value <revision>
select-tuple from-object
- "view?title=" relative-link-prefix set
+ URL" $wiki/view/" adjust-url present relative-link-prefix set
] >>init
-
{ wiki "view" } >>template ;
: add-revision ( revision -- )
: <edit-article-action> ( -- action )
<page-action>
+ "title" >>rest
[
validate-title
"title" value <article> select-tuple [
revision>> <revision> select-tuple from-object
] when*
] >>init
-
{ wiki "edit" } >>template
-
[
validate-title
{ { "content" [ v-required ] } } validate-params
: <list-revisions-action> ( -- action )
<page-action>
+ "title" >>rest
[
validate-title
list-revisions "revisions" set-value
: <list-revisions-feed-action> ( -- action )
<feed-action>
+ "title" >>rest
[ validate-title ] >>init
[ "Revisions of " "title" value append ] >>title
[ "title" value revisions-url ] >>url
: <rollback-action> ( -- action )
<action>
[ validate-integer-id ] >>validate
-
[
"id" value <revision> select-tuple clone f >>id
[ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit ;
: list-changes ( -- seq )
- "id" value <revision> select-tuples
+ f <revision> select-tuples
reverse-chronological-order ;
: <list-changes-action> ( -- action )
<page-action>
[ list-changes "changes" set-value ] >>init
-
{ wiki "changes" } >>template ;
: <list-changes-feed-action> ( -- action )
: <delete-action> ( -- action )
<action>
[ validate-title ] >>validate
-
[
"title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
] >>init
-
{ wiki "diff" } >>template ;
: <list-articles-action> ( -- action )
[ [ title>> ] compare ] sort
"articles" set-value
] >>init
-
{ wiki "articles" } >>template ;
: list-user-edits ( -- seq )
: <user-edits-action> ( -- action )
<page-action>
+ "author" >>rest
[
validate-author
list-user-edits "user-edits" set-value
: <user-edits-feed-action> ( -- action )
<feed-action>
+ "author" >>rest
[ validate-author ] >>init
[ "Edits by " "author" value append ] >>title
[ "author" value user-edits-url ] >>url
projects / factor.git / commitdiff