From a368b5ad487cfa5f1a11f9cef111576824f6d23c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Jun 2008 17:08:19 -0500
Subject: [PATCH 01/90] Clarification
---
core/parser/parser-docs.factor | 10 +++++++---
1 file changed, 7 insertions(+), 3 deletions(-)
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 1dc47432d3..2ec9f2de54 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -117,14 +117,18 @@ $nl
{ $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" }
From a89c9758df900de8faace1661ec9e3a2e4310e3c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Jun 2008 18:53:53 -0500
Subject: [PATCH 02/90] Check port number
---
extra/http/http-tests.factor | 8 ++++----
extra/http/http.factor | 9 +--------
extra/http/server/server.factor | 26 +++++++++++++++++++++-----
extra/io/server/server.factor | 10 ++++++----
4 files changed, 32 insertions(+), 21 deletions(-)
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 81ada558f3..aa11dd6798 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -7,7 +7,7 @@ IN: http.tests
: 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
@@ -18,7 +18,7 @@ blah
[
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" } }
@@ -49,14 +49,14 @@ read-request-test-1' 1array [
] 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" } }
diff --git a/extra/http/http.factor b/extra/http/http.factor
index d7fc1b766e..521c18c703 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger
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
@@ -142,7 +141,6 @@ cookies ;
request new
"1.1" >>version
<url>
- "http" >>protocol
H{ } clone >>query
>>url
H{ } clone >>header
@@ -202,7 +200,6 @@ TUPLE: post-data raw content content-type ;
: extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi*
- ensure-port
drop ;
: extract-cookies ( request -- request )
@@ -214,9 +211,6 @@ TUPLE: post-data raw content content-type ;
: 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
@@ -224,7 +218,6 @@ TUPLE: post-data raw content content-type ;
read-request-version
read-request-header
read-post-data
- detect-protocol
extract-host
extract-cookies ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 792757b182..642e9f77f0 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -2,16 +2,18 @@
! 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
@@ -88,12 +90,26 @@ LOG: httpd-hit NOTICE
: 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 ( -- )
diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor
index 359b9c6fb4..c855fba6be 100755
--- a/extra/io/server/server.factor
+++ b/extra/io/server/server.factor
@@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files
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
@@ -15,9 +15,10 @@ SYMBOL: remote-address
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
@@ -25,7 +26,8 @@ LOG: accepted-connection NOTICE
: 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 -- )
@@ -59,7 +61,7 @@ LOG: received-datagram NOTICE
: 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
From 9aadcace246947ccadd04c7ca122ea5162230991 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Jun 2008 18:54:38 -0500
Subject: [PATCH 03/90] Fix pool behavior with image save/restart
---
extra/io/pools/pools.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/io/pools/pools.factor b/extra/io/pools/pools.factor
index 033ba3cbfb..0e37e41a76 100644
--- a/extra/io/pools/pools.factor
+++ b/extra/io/pools/pools.factor
@@ -10,7 +10,7 @@ TUPLE: pool connections disposed expired ;
dup check-disposed
dup expired>> expired? [
ALIEN: 31337 >>expired
- connections>> [ delete-all ] [ dispose-each ] bi
+ connections>> delete-all
] [ drop ] if ;
: <pool> ( class -- pool )
@@ -34,6 +34,7 @@ GENERIC: make-connection ( pool -- conn )
dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn )
+ dup check-pool
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;
From 3358381510851552d7c3d3005dff884bf303d11f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Jun 2008 18:54:50 -0500
Subject: [PATCH 04/90] Better support for rest parameters on URLs
---
extra/furnace/furnace.factor | 51 ++++++++++++++----------------
extra/webapps/blogs/blogs.factor | 2 ++
extra/webapps/blogs/edit-post.xml | 4 +--
extra/webapps/blogs/list-posts.xml | 6 ++--
extra/webapps/blogs/user-posts.xml | 8 ++---
extra/webapps/blogs/view-post.xml | 8 ++---
extra/webapps/wiki/articles.xml | 2 +-
extra/webapps/wiki/changes.xml | 32 ++++++++++++-------
extra/webapps/wiki/diff.xml | 4 +--
extra/webapps/wiki/page-common.xml | 8 ++---
extra/webapps/wiki/revisions.xml | 10 +++---
extra/webapps/wiki/user-edits.xml | 6 ++--
extra/webapps/wiki/view.xml | 2 +-
extra/webapps/wiki/wiki.factor | 42 +++++++++++-------------
14 files changed, 93 insertions(+), 92 deletions(-)
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 99ccf33eec..6ddd84a254 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -97,15 +97,21 @@ SYMBOL: exit-continuation
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 ;
@@ -114,23 +120,11 @@ 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
- 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 ]
@@ -158,11 +152,12 @@ CHLOE: a
[
[
<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
diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor
index 8dbf7db690..882584f014 100644
--- a/extra/webapps/blogs/blogs.factor
+++ b/extra/webapps/blogs/blogs.factor
@@ -164,6 +164,8 @@ M: comment entity-url
: <edit-post-action> ( -- action )
<page-action>
+ "id" >>rest
+
[
validate-integer-id
"id" value <post> select-tuple from-object
diff --git a/extra/webapps/blogs/edit-post.xml b/extra/webapps/blogs/edit-post.xml
index da88a78ab0..4522f8606b 100644
--- a/extra/webapps/blogs/edit-post.xml
+++ b/extra/webapps/blogs/edit-post.xml
@@ -15,13 +15,13 @@
<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>
diff --git a/extra/webapps/blogs/list-posts.xml b/extra/webapps/blogs/list-posts.xml
index 9c9685fe74..94a5a69775 100644
--- a/extra/webapps/blogs/list-posts.xml
+++ b/extra/webapps/blogs/list-posts.xml
@@ -7,7 +7,7 @@
<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>
@@ -18,13 +18,13 @@
<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>
diff --git a/extra/webapps/blogs/user-posts.xml b/extra/webapps/blogs/user-posts.xml
index 95fae23b34..d94b598fc0 100644
--- a/extra/webapps/blogs/user-posts.xml
+++ b/extra/webapps/blogs/user-posts.xml
@@ -2,7 +2,7 @@
<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>
@@ -13,7 +13,7 @@
<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>
@@ -24,13 +24,13 @@
<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>
diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml
index 23bf513946..fae9ff3e76 100644
--- a/extra/webapps/blogs/view-post.xml
+++ b/extra/webapps/blogs/view-post.xml
@@ -2,11 +2,11 @@
<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>
@@ -18,13 +18,13 @@
<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>
diff --git a/extra/webapps/wiki/articles.xml b/extra/webapps/wiki/articles.xml
index e19c531d3d..9b2ae930fb 100644
--- a/extra/webapps/wiki/articles.xml
+++ b/extra/webapps/wiki/articles.xml
@@ -7,7 +7,7 @@
<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>
diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml
index 5b3e9de2c4..1515c4924a 100644
--- a/extra/webapps/wiki/changes.xml
+++ b/extra/webapps/wiki/changes.xml
@@ -4,16 +4,26 @@
<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>
diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml
index 35afe51b66..9d65531eb0 100644
--- a/extra/webapps/wiki/diff.xml
+++ b/extra/webapps/wiki/diff.xml
@@ -8,13 +8,13 @@
<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>
diff --git a/extra/webapps/wiki/page-common.xml b/extra/webapps/wiki/page-common.xml
index 675cb8cd65..0d029946f8 100644
--- a/extra/webapps/wiki/page-common.xml
+++ b/extra/webapps/wiki/page-common.xml
@@ -2,16 +2,16 @@
<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>
diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml
index 2a909e6ab3..97a051cd96 100644
--- a/extra/webapps/wiki/revisions.xml
+++ b/extra/webapps/wiki/revisions.xml
@@ -8,14 +8,14 @@
<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>
@@ -24,7 +24,7 @@
<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>
@@ -51,6 +51,6 @@
</table>
<input type="submit" value="View" />
- </form>
+ </t:form>
</t:chloe>
diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml
index 6f22982f12..6f6ada2dbd 100644
--- a/extra/webapps/wiki/user-edits.xml
+++ b/extra/webapps/wiki/user-edits.xml
@@ -2,7 +2,7 @@
<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>
@@ -11,9 +11,9 @@
<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>
diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml
index 30dfb71270..7d2c7869b5 100644
--- a/extra/webapps/wiki/view.xml
+++ b/extra/webapps/wiki/view.xml
@@ -8,6 +8,6 @@
<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>
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 21a983fc7b..4791278974 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -1,7 +1,7 @@
! 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
@@ -15,20 +15,19 @@ validators
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 ;
@@ -83,12 +82,9 @@ M: revision feed-entry-url id>> revision-url ;
: <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
@@ -100,13 +96,13 @@ M: revision feed-entry-url id>> revision-url ;
: <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 -- )
@@ -121,15 +117,14 @@ M: revision feed-entry-url id>> revision-url ;
: <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
@@ -148,6 +143,7 @@ M: revision feed-entry-url id>> revision-url ;
: <list-revisions-action> ( -- action )
<page-action>
+ "title" >>rest
[
validate-title
list-revisions "revisions" set-value
@@ -156,6 +152,7 @@ M: revision feed-entry-url id>> revision-url ;
: <list-revisions-feed-action> ( -- action )
<feed-action>
+ "title" >>rest
[ validate-title ] >>init
[ "Revisions of " "title" value append ] >>title
[ "title" value revisions-url ] >>url
@@ -164,20 +161,18 @@ M: revision feed-entry-url id>> revision-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 )
@@ -189,7 +184,6 @@ M: revision feed-entry-url id>> revision-url ;
: <delete-action> ( -- action )
<action>
[ validate-title ] >>validate
-
[
"title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples
@@ -213,7 +207,6 @@ M: revision feed-entry-url id>> revision-url ;
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
] >>init
-
{ wiki "diff" } >>template ;
: <list-articles-action> ( -- action )
@@ -223,7 +216,6 @@ M: revision feed-entry-url id>> revision-url ;
[ [ title>> ] compare ] sort
"articles" set-value
] >>init
-
{ wiki "articles" } >>template ;
: list-user-edits ( -- seq )
@@ -232,6 +224,7 @@ M: revision feed-entry-url id>> revision-url ;
: <user-edits-action> ( -- action )
<page-action>
+ "author" >>rest
[
validate-author
list-user-edits "user-edits" set-value
@@ -240,6 +233,7 @@ M: revision feed-entry-url id>> revision-url ;
: <user-edits-feed-action> ( -- action )
<feed-action>
+ "author" >>rest
[ validate-author ] >>init
[ "Edits by " "author" value append ] >>title
[ "author" value user-edits-url ] >>url
From 61a9a8c0ec36086e9ee69318978e287a0e78cde0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Jun 2008 18:59:06 -0500
Subject: [PATCH 05/90] Fix <sliced-clumps>
---
core/grouping/grouping-tests.factor | 2 ++
core/grouping/grouping.factor | 2 +-
2 files changed, 3 insertions(+), 1 deletion(-)
diff --git a/core/grouping/grouping-tests.factor b/core/grouping/grouping-tests.factor
index dcf62e1117..dc3d970fbf 100644
--- a/core/grouping/grouping-tests.factor
+++ b/core/grouping/grouping-tests.factor
@@ -10,3 +10,5 @@ IN: grouping.tests
2 over set-length
>array
] unit-test
+
+[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor
index c12d43160c..caf46e5480 100644
--- a/core/grouping/grouping.factor
+++ b/core/grouping/grouping.factor
@@ -56,7 +56,7 @@ M: clumps set-length
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
From 75ac2528ae18c6b80d7969357e9f108ea943f3f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Jun 2008 19:00:41 -0500
Subject: [PATCH 06/90] Remove obsolete comment
---
extra/io/streams/duplex/duplex.factor | 3 ---
1 file changed, 3 deletions(-)
diff --git a/extra/io/streams/duplex/duplex.factor b/extra/io/streams/duplex/duplex.factor
index 02d7ab61be..51b4b8d860 100755
--- a/extra/io/streams/duplex/duplex.factor
+++ b/extra/io/streams/duplex/duplex.factor
@@ -5,9 +5,6 @@ io.encodings.private io.timeouts debugger inspector listener
accessors delegate delegate.protocols ;
IN: io.streams.duplex
-! We ensure that the stream can only be closed once, to preserve
-! integrity of duplex I/O ports.
-
TUPLE: duplex-stream in out ;
C: <duplex-stream> duplex-stream
From 49523c508b12768adfc60ee5c254e718a851715d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 00:47:47 -0500
Subject: [PATCH 07/90] More flexible furnace authentication; fix planet
---
extra/furnace/actions/actions.factor | 30 ++--
extra/furnace/auth/login/login.factor | 64 ++++---
extra/furnace/furnace.factor | 7 +-
.../server/redirection/redirection.factor | 8 +-
extra/http/server/server.factor | 2 +-
extra/webapps/blogs/blogs.factor | 168 ++++++++++++------
.../blogs/{user-posts.xml => posts-by.xml} | 0
extra/webapps/blogs/view-post.xml | 2 +-
extra/webapps/pastebin/pastebin.factor | 34 ++--
extra/webapps/planet/planet.factor | 28 +--
extra/webapps/wiki/wiki.factor | 56 ++++--
11 files changed, 256 insertions(+), 143 deletions(-)
rename extra/webapps/blogs/{user-posts.xml => posts-by.xml} (100%)
diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor
index 1cef8e24e5..a281687096 100755
--- a/extra/furnace/actions/actions.factor
+++ b/extra/furnace/actions/actions.factor
@@ -29,14 +29,10 @@ SYMBOL: rest
CHLOE: validation-messages drop render-validation-messages ;
-TUPLE: action rest init display validate submit ;
+TUPLE: action rest authorize init display validate submit ;
: new-action ( class -- action )
- new
- [ ] >>init
- [ <400> ] >>display
- [ ] >>validate
- [ <400> ] >>submit ;
+ new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
: <action> ( -- action )
action new-action ;
@@ -46,18 +42,28 @@ TUPLE: action rest init display validate submit ;
: handle-get ( action -- response )
'[
- ,
- [ init>> call ]
- [ drop flashed-variables restore-flash ]
- [ display>> call ]
- tri
+ , dup display>> [
+ {
+ [ init>> call ]
+ [ authorize>> call ]
+ [ drop flashed-variables restore-flash ]
+ [ display>> call ]
+ } cleave
+ ] [ drop <400> ] if
] with-exit-continuation ;
: validation-failed ( -- * )
request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
: (handle-post) ( action -- response )
- [ validate>> call ] [ submit>> call ] bi ;
+ '[
+ , dup submit>> [
+ [ validate>> call ]
+ [ authorize>> call ]
+ [ submit>> call ]
+ tri
+ ] [ drop <400> ] if
+ ] with-exit-continuation ;
: param ( name -- value )
params get at ;
diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index d0c4e00953..a1d2bf47c3 100755
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -49,6 +49,10 @@ TUPLE: login < dispatcher users checksum ;
TUPLE: protected < filter-responder description capabilities ;
+: <protected> ( responder -- protected )
+ protected new
+ swap >>responder ;
+
: users ( -- provider )
login get users>> ;
@@ -85,13 +89,17 @@ M: user-saver dispose
"invalid username or password" validation-error
validation-failed ;
+SYMBOL: description
+SYMBOL: capabilities
+
+: flashed-variables { description capabilities } ;
+
: <login-action> ( -- action )
<page-action>
[
- protected fget [
- [ description>> "description" set-value ]
- [ capabilities>> words>strings "capabilities" set-value ] bi
- ] when*
+ flashed-variables restore-flash
+ description get "description" set-value
+ capabilities get words>strings "capabilities" set-value
] >>init
{ login "login" } >>template
@@ -200,7 +208,10 @@ M: user-saver dispose
drop
URL" $login" end-aside
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "edit your profile" >>description ;
! ! ! Password recovery
@@ -316,32 +327,36 @@ SYMBOL: lost-password-from
] >>submit ;
! ! ! Authentication logic
-: <protected> ( responder -- protected )
- protected new
- swap >>responder ;
-
: show-login-page ( -- response )
begin-aside
- URL" $login/login" { protected } <flash-redirect> ;
+ protected get description>> description set
+ protected get capabilities>> capabilities set
+ URL" $login/login" flashed-variables <flash-redirect> ;
-: check-capabilities ( responder user -- ? )
- [ capabilities>> ] bi@ subset? ;
+: login-required ( -- * )
+ show-login-page exit-with ;
+
+: have-capability? ( capability -- ? )
+ logged-in-user get capabilities>> member? ;
+
+: check-capabilities ( responder user/f -- ? )
+ dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ;
M: protected call-responder* ( path responder -- response )
dup protected set
- uid dup [
- users get-user 2dup check-capabilities [
- [ logged-in-user set ] [ save-user-after ] bi
- call-next-method
- ] [
- 3drop show-login-page
- ] if
- ] [
- 3drop show-login-page
- ] if ;
+ dup logged-in-user get check-capabilities
+ [ call-next-method ] [ 2drop show-login-page ] if ;
+
+: init-user ( -- )
+ uid [
+ users get-user
+ [ logged-in-user set ]
+ [ save-user-after ] bi
+ ] when* ;
M: login call-responder* ( path responder -- response )
dup login set
+ init-user
call-next-method ;
: <login-boilerplate> ( responder -- responder' )
@@ -359,10 +374,7 @@ M: login call-responder* ( path responder -- response )
! ! ! Configuration
: allow-edit-profile ( login -- login )
- <edit-profile-action> <protected>
- "edit your profile" >>description
- <login-boilerplate>
- "edit-profile" add-responder ;
+ <edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;
: allow-registration ( login -- login )
<register-action> <login-boilerplate>
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 6ddd84a254..cdee2821b6 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -102,14 +102,15 @@ SYMBOL: exit-continuation
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( tag -- url )
- dup "value" optional-attr [ ] [
+ dup "value" optional-attr
+ [ value ] [
<url>
swap
[ a-url-path >>path ]
[ "query" optional-attr parse-query-attr >>query ]
bi
- ] ?if
- adjust-url relative-to-request ;
+ adjust-url relative-to-request
+ ] ?if ;
CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
diff --git a/extra/http/server/redirection/redirection.factor b/extra/http/server/redirection/redirection.factor
index 3cd01345aa..c1d2eaa63a 100644
--- a/extra/http/server/redirection/redirection.factor
+++ b/extra/http/server/redirection/redirection.factor
@@ -1,10 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators namespaces
+USING: kernel accessors combinators namespaces strings
logging urls http http.server http.server.responses ;
IN: http.server.redirection
-: relative-to-request ( url -- url' )
+GENERIC: relative-to-request ( url -- url' )
+
+M: string relative-to-request ;
+
+M: url relative-to-request
request get url>>
clone
f >>query
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 642e9f77f0..376889b46b 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -68,7 +68,7 @@ main-responder global [ <404> <trivial-responder> or ] change-at
[
utf8 [
development-mode get
- [ http-error. ] [ drop "Response error" throw ] if
+ [ http-error. ] [ drop "Response error" rethrow ] if
] with-encoded-output
] recover
] if
diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor
index 882584f014..100d4226b7 100644
--- a/extra/webapps/blogs/blogs.factor
+++ b/extra/webapps/blogs/blogs.factor
@@ -1,24 +1,33 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math.order math.parser
-urls validators html.components db.types db.tuples calendar
-http.server.dispatchers
-furnace furnace.actions furnace.auth.login furnace.boilerplate
-furnace.sessions furnace.syndication ;
+urls validators html.components db db.types db.tuples calendar
+present http.server.dispatchers
+furnace
+furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.boilerplate
+furnace.sessions
+furnace.syndication ;
IN: webapps.blogs
TUPLE: blogs < dispatcher ;
+SYMBOL: can-administer-blogs?
+
+can-administer-blogs? define-capability
+
: view-post-url ( id -- url )
- number>string "$blogs/post/" prepend >url ;
+ present "$blogs/post/" prepend >url ;
: view-comment-url ( parent id -- url )
[ view-post-url ] dip >>anchor ;
: list-posts-url ( -- url )
- URL" $blogs/" ;
+ "$blogs/" >url ;
-: user-posts-url ( author -- url )
+: posts-by-url ( author -- url )
"$blogs/by/" prepend >url ;
TUPLE: entity id author date content ;
@@ -39,7 +48,7 @@ M: entity feed-entry-date date>> ;
TUPLE: post < entity title comments ;
M: post feed-entry-title
- [ author>> ] [ drop ": " ] [ title>> ] tri 3append ;
+ [ author>> ] [ title>> ] bi ": " swap 3append ;
M: post entity-url
id>> view-post-url ;
@@ -79,19 +88,16 @@ M: comment entity-url
[ [ date>> ] compare invert-comparison ] sort ;
: validate-author ( -- )
- { { "author" [ [ v-username ] v-optional ] } } validate-params ;
+ { { "author" [ v-username ] } } validate-params ;
: list-posts ( -- posts )
f <post> "author" value >>author
- select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
+ select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
reverse-chronological-order ;
: <list-posts-action> ( -- action )
<page-action>
- [
- list-posts "posts" set-value
- ] >>init
-
+ [ list-posts "posts" set-value ] >>init
{ blogs "list-posts" } >>template ;
: <list-posts-feed-action> ( -- action )
@@ -100,21 +106,24 @@ M: comment entity-url
[ list-posts ] >>entries
[ list-posts-url ] >>url ;
-: <user-posts-action> ( -- action )
+: <posts-by-action> ( -- action )
<page-action>
+
"author" >>rest
+
[
validate-author
list-posts "posts" set-value
] >>init
- { blogs "user-posts" } >>template ;
-: <user-posts-feed-action> ( -- action )
+ { blogs "posts-by" } >>template ;
+
+: <posts-by-feed-action> ( -- action )
<feed-action>
[ validate-author ] >>init
[ "Recent Posts by " "author" value append ] >>title
[ list-posts ] >>entries
- [ "author" value user-posts-url ] >>url ;
+ [ "author" value posts-by-url ] >>url ;
: <post-feed-action> ( -- action )
<feed-action>
@@ -125,6 +134,7 @@ M: comment entity-url
: <view-post-action> ( -- action )
<page-action>
+
"id" >>rest
[
@@ -147,6 +157,7 @@ M: comment entity-url
: <new-post-action> ( -- action )
<page-action>
+
[
validate-post
uid "author" set-value
@@ -160,40 +171,76 @@ M: comment entity-url
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
- { blogs "new-post" } >>template ;
+ { blogs "new-post" } >>template
+
+ <protected>
+ "make a new blog post" >>description ;
+
+: authorize-author ( author -- )
+ uid = can-administer-blogs? have-capability? or
+ [ login-required ] unless ;
+
+: do-post-action ( -- )
+ validate-integer-id
+ "id" value <post> select-tuple from-object ;
: <edit-post-action> ( -- action )
<page-action>
+
"id" >>rest
- [
- validate-integer-id
- "id" value <post> select-tuple from-object
- ] >>init
+ [ do-post-action ] >>init
+
+ [ do-post-action validate-post ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
[
- validate-integer-id
- validate-post
- ] >>validate
-
- [
- "id" value <post> select-tuple
- dup { "title" "content" } deposit-slots
+ "id" value <post>
+ dup { "title" "author" "date" "content" } deposit-slots
[ update-tuple ] [ entity-url <redirect> ] bi
] >>submit
- { blogs "edit-post" } >>template ;
-
+ { blogs "edit-post" } >>template
+
+ <protected>
+ "edit a blog post" >>description ;
+
+: delete-post ( id -- )
+ [ <post> delete-tuples ] [ f <comment> delete-tuples ] bi ;
+
: <delete-post-action> ( -- action )
<action>
+
+ [ do-post-action ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
+
[
- validate-integer-id
- { { "author" [ v-username ] } } validate-params
- ] >>validate
+ [ "id" value delete-post ] with-transaction
+ "author" value posts-by-url <redirect>
+ ] >>submit
+
+ <protected>
+ "delete a blog post" >>description ;
+
+: <delete-author-action> ( -- action )
+ <action>
+
+ [ validate-author ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
+
[
- "id" value <post> delete-tuples
- "author" value user-posts-url <redirect>
- ] >>submit ;
+ [
+ f <post> "author" value >>author select-tuples [ id>> delete-post ] each
+ f f <comment> "author" value >>author delete-tuples
+ ] with-transaction
+ "author" value posts-by-url <redirect>
+ ] >>submit
+
+ <protected>
+ "delete a blog post" >>description ;
: validate-comment ( -- )
{
@@ -215,41 +262,44 @@ M: comment entity-url
uid >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
- ] >>submit ;
-
+ ] >>submit
+
+ <protected>
+ "make a comment" >>description ;
+
: <delete-comment-action> ( -- action )
<action>
+
[
validate-integer-id
{ { "parent" [ v-integer ] } } validate-params
] >>validate
+
+ [
+ "parent" value <post> select-tuple
+ author>> authorize-author
+ ] >>authorize
+
[
f "id" value <comment> delete-tuples
"parent" value view-post-url <redirect>
- ] >>submit ;
-
+ ] >>submit
+
+ <protected>
+ "delete a comment" >>description ;
+
: <blogs> ( -- dispatcher )
blogs new-dispatcher
<list-posts-action> "" add-responder
<list-posts-feed-action> "posts.atom" add-responder
- <user-posts-action> "by" add-responder
- <user-posts-feed-action> "by.atom" add-responder
+ <posts-by-action> "by" add-responder
+ <posts-by-feed-action> "by.atom" add-responder
<view-post-action> "post" add-responder
<post-feed-action> "post.atom" add-responder
- <new-post-action> <protected>
- "make a new blog post" >>description
- "new-post" add-responder
- <edit-post-action> <protected>
- "edit a blog post" >>description
- "edit-post" add-responder
- <delete-post-action> <protected>
- "delete a blog post" >>description
- "delete-post" add-responder
- <new-comment-action> <protected>
- "make a comment" >>description
- "new-comment" add-responder
- <delete-comment-action> <protected>
- "delete a comment" >>description
- "delete-comment" add-responder
+ <new-post-action> "new-post" add-responder
+ <edit-post-action> "edit-post" add-responder
+ <delete-post-action> "delete-post" add-responder
+ <new-comment-action> "new-comment" add-responder
+ <delete-comment-action> "delete-comment" add-responder
<boilerplate>
{ blogs "blogs-common" } >>template ;
diff --git a/extra/webapps/blogs/user-posts.xml b/extra/webapps/blogs/posts-by.xml
similarity index 100%
rename from extra/webapps/blogs/user-posts.xml
rename to extra/webapps/blogs/posts-by.xml
diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml
index fae9ff3e76..55bdd2e806 100644
--- a/extra/webapps/blogs/view-post.xml
+++ b/extra/webapps/blogs/view-post.xml
@@ -33,7 +33,7 @@
<hr/>
<p class="comment-header">
- Comment by <t:label t:name="author" /> on <t:label t:name="date" />:
+ <a name="@id">Comment by <t:label t:name="author" /> on <t:label t:name="date" />:</a>
</p>
<p class="posting-body">
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index 2fbe5b4816..f6b604c06d 100644
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -19,6 +19,10 @@ IN: webapps.pastebin
TUPLE: pastebin < dispatcher ;
+SYMBOL: can-delete-pastes?
+
+can-delete-pastes? define-capability
+
! ! !
! DOMAIN MODEL
! ! !
@@ -170,13 +174,20 @@ M: annotation entity-url
: <delete-paste-action> ( -- action )
<action>
+
[ validate-integer-id ] >>validate
[
- "id" value <paste> delete-tuples
- "id" value f <annotation> delete-tuples
+ [
+ "id" value <paste> delete-tuples
+ "id" value f <annotation> delete-tuples
+ ] with-transaction
URL" $pastebin/list" <redirect>
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "delete pastes" >>description
+ { can-delete-pastes? } >>capabilities ;
! ! !
! ANNOTATIONS
@@ -199,6 +210,7 @@ M: annotation entity-url
: <delete-annotation-action> ( -- action )
<action>
+
[ { { "id" [ v-number ] } } validate-params ] >>validate
[
@@ -206,11 +218,11 @@ M: annotation entity-url
[ delete-tuples ]
[ parent>> paste-url <redirect> ]
bi
- ] >>submit ;
+ ] >>submit
-SYMBOL: can-delete-pastes?
-
-can-delete-pastes? define-capability
+ <protected>
+ "delete annotations" >>description
+ { can-delete-pastes? } >>capabilities ;
: <pastebin> ( -- responder )
pastebin new-dispatcher
@@ -219,13 +231,9 @@ can-delete-pastes? define-capability
<paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
- <delete-paste-action> <protected>
- "delete pastes" >>description
- { can-delete-pastes? } >>capabilities "delete-paste" add-responder
+ <delete-paste-action> "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
- <delete-annotation-action> <protected>
- "delete annotations" >>description
- { can-delete-pastes? } >>capabilities "delete-annotation" add-responder
+ <delete-annotation-action> "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 3e780132b4..888d4bd145 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -18,6 +18,10 @@ IN: webapps.planet
TUPLE: planet-factor < dispatcher ;
+SYMBOL: can-administer-planet-factor?
+
+can-administer-planet-factor? define-capability
+
TUPLE: planet-factor-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ;
@@ -30,8 +34,8 @@ blog "BLOGS"
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
- { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
- { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
+ { "www-url" "WWWURL" URL +not-null+ }
+ { "feed-url" "FEEDURL" URL +not-null+ }
} define-persistent
TUPLE: posting < entry id ;
@@ -40,7 +44,7 @@ posting "POSTINGS"
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "title" "TITLE" { VARCHAR 256 } +not-null+ }
- { "url" "LINK" { VARCHAR 256 } +not-null+ }
+ { "url" "LINK" URL +not-null+ }
{ "description" "DESCRIPTION" TEXT +not-null+ }
{ "date" "DATE" TIMESTAMP +not-null+ }
} define-persistent
@@ -134,6 +138,7 @@ posting "POSTINGS"
: <new-blog-action> ( -- action )
<page-action>
+
{ planet-factor "new-blog" } >>template
[ validate-blog ] >>validate
@@ -150,9 +155,10 @@ posting "POSTINGS"
]
tri
] >>submit ;
-
+
: <edit-blog-action> ( -- action )
<page-action>
+
[
validate-integer-id
"id" value <blog> select-tuple from-object
@@ -184,20 +190,16 @@ posting "POSTINGS"
<update-action> "update" add-responder
<new-blog-action> "new-blog" add-responder
<edit-blog-action> "edit-blog" add-responder
- <delete-blog-action> "delete-blog" add-responder ;
-
-SYMBOL: can-administer-planet-factor?
-
-can-administer-planet-factor? define-capability
+ <delete-blog-action> "delete-blog" add-responder
+ <protected>
+ "administer Planet Factor" >>description
+ { can-administer-planet-factor? } >>capabilities ;
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
<planet-feed-action> "feed.xml" add-responder
- <planet-factor-admin> <protected>
- "administer Planet Factor" >>description
- { can-administer-planet-factor? } >>capabilities
- "admin" add-responder
+ <planet-factor-admin> "admin" add-responder
<boilerplate>
{ planet-factor "planet-common" } >>template ;
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 4791278974..18130f5144 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -31,6 +31,10 @@ IN: webapps.wiki
TUPLE: wiki < dispatcher ;
+SYMBOL: can-delete-wiki-articles?
+
+can-delete-wiki-articles? define-capability
+
TUPLE: article title revision ;
article "ARTICLES" {
@@ -81,10 +85,13 @@ M: revision feed-entry-url id>> revision-url ;
: <view-article-action> ( -- action )
<action>
+
"title" >>rest
+
[
validate-title
] >>init
+
[
"title" value dup <article> select-tuple [
revision>> <revision> select-tuple from-object
@@ -96,13 +103,16 @@ M: revision feed-entry-url id>> revision-url ;
: <view-revision-action> ( -- action )
<page-action>
+
"id" >>rest
+
[
validate-integer-id
"id" value <revision>
select-tuple from-object
URL" $wiki/view/" adjust-url present relative-link-prefix set
] >>init
+
{ wiki "view" } >>template ;
: add-revision ( revision -- )
@@ -117,14 +127,18 @@ M: revision feed-entry-url id>> revision-url ;
: <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
@@ -135,7 +149,10 @@ M: revision feed-entry-url id>> revision-url ;
logged-in-user get username>> >>author
"content" value >>content
[ add-revision ] [ title>> view-url <redirect> ] bi
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "edit wiki articles" >>description ;
: list-revisions ( -- seq )
f <revision> "title" value >>title select-tuples
@@ -143,24 +160,34 @@ M: revision feed-entry-url id>> revision-url ;
: <list-revisions-action> ( -- action )
<page-action>
+
"title" >>rest
+
[
validate-title
list-revisions "revisions" set-value
] >>init
+
{ wiki "revisions" } >>template ;
: <list-revisions-feed-action> ( -- action )
<feed-action>
+
"title" >>rest
+
[ validate-title ] >>init
+
[ "Revisions of " "title" value append ] >>title
+
[ "title" value revisions-url ] >>url
+
[ list-revisions ] >>entries ;
: <rollback-action> ( -- action )
<action>
+
[ validate-integer-id ] >>validate
+
[
"id" value <revision> select-tuple clone f >>id
[ add-revision ] [ title>> view-url <redirect> ] bi
@@ -183,12 +210,18 @@ M: revision feed-entry-url id>> revision-url ;
: <delete-action> ( -- action )
<action>
+
[ validate-title ] >>validate
+
[
"title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples
URL" $wiki" <redirect>
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "delete wiki articles" >>description
+ { can-delete-wiki-articles? } >>capabilities ;
: <diff-action> ( -- action )
<page-action>
@@ -207,15 +240,18 @@ M: revision feed-entry-url id>> revision-url ;
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
] >>init
+
{ wiki "diff" } >>template ;
: <list-articles-action> ( -- action )
<page-action>
+
[
f <article> select-tuples
[ [ title>> ] compare ] sort
"articles" set-value
] >>init
+
{ wiki "articles" } >>template ;
: list-user-edits ( -- seq )
@@ -224,11 +260,14 @@ M: revision feed-entry-url id>> revision-url ;
: <user-edits-action> ( -- action )
<page-action>
+
"author" >>rest
+
[
validate-author
list-user-edits "user-edits" set-value
] >>init
+
{ wiki "user-edits" } >>template ;
: <user-edits-feed-action> ( -- action )
@@ -239,10 +278,6 @@ M: revision feed-entry-url id>> revision-url ;
[ "author" value user-edits-url ] >>url
[ list-user-edits ] >>entries ;
-SYMBOL: can-delete-wiki-articles?
-
-can-delete-wiki-articles? define-capability
-
: <article-boilerplate> ( responder -- responder' )
<boilerplate>
{ wiki "page-common" } >>template ;
@@ -255,18 +290,13 @@ can-delete-wiki-articles? define-capability
<list-revisions-action> <article-boilerplate> "revisions" add-responder
<list-revisions-feed-action> "revisions.atom" add-responder
<diff-action> <article-boilerplate> "diff" add-responder
- <edit-article-action> <article-boilerplate> <protected>
- "edit wiki articles" >>description
- "edit" add-responder
+ <edit-article-action> <article-boilerplate> "edit" add-responder
<rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
<list-articles-action> "articles" add-responder
<list-changes-action> "changes" add-responder
<user-edits-feed-action> "user-edits.atom" add-responder
<list-changes-feed-action> "changes.atom" add-responder
- <delete-action> <protected>
- "delete wiki articles" >>description
- { can-delete-wiki-articles? } >>capabilities
- "delete" add-responder
+ <delete-action> "delete" add-responder
<boilerplate>
{ wiki "wiki-common" } >>template ;
From 7bd7222b07a1d19c26d7eab094f1f5eff369ba4a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 12 Jun 2008 22:51:20 -0700
Subject: [PATCH 08/90] Refactor windows.com.wrapper to make better use of fry
and cleave to show what is going on. Create named words for wrapper
alien-callbacks so it is easy to see what code gets generated. Change
com-query-interface to malloc the buffer for the returned interface pointer
to avoid GC heisenbugs when calling into a com-wrapped factor object
---
extra/windows/com/com.factor | 8 +-
extra/windows/com/wrapper/wrapper.factor | 110 ++++++++++++++---------
2 files changed, 74 insertions(+), 44 deletions(-)
mode change 100644 => 100755 extra/windows/com/com.factor
diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor
old mode 100644
new mode 100755
index 4833a7412a..4202ed4c56
--- a/extra/windows/com/com.factor
+++ b/extra/windows/com/com.factor
@@ -1,5 +1,5 @@
USING: alien alien.c-types windows.com.syntax windows.ole32
-windows.types continuations kernel alien.syntax ;
+windows.types continuations kernel alien.syntax libc ;
IN: windows.com
LIBRARY: ole32
@@ -27,9 +27,9 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
: com-query-interface ( interface iid -- interface' )
- f <void*>
- [ IUnknown::QueryInterface ole32-error ] keep
- *void* ;
+ "void*" heap-size [
+ [ IUnknown::QueryInterface ole32-error ] keep *void*
+ ] with-malloc ;
: com-add-ref ( interface -- interface )
[ IUnknown::AddRef drop ] keep ; inline
diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor
index 972a75ecb9..6d6aa078e8 100755
--- a/extra/windows/com/wrapper/wrapper.factor
+++ b/extra/windows/com/wrapper/wrapper.factor
@@ -1,11 +1,12 @@
USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel
-sequences.lib namespaces windows.ole32 libc
+sequences.lib namespaces windows.ole32 libc vocabs
assocs accessors arrays sequences quotations combinators
-math combinators.lib words compiler.units destructors ;
+math combinators.lib words compiler.units destructors fry
+math.parser ;
IN: windows.com.wrapper
-TUPLE: com-wrapper vtbls freed? ;
+TUPLE: com-wrapper vtbls disposed ;
<PRIVATE
@@ -14,6 +15,16 @@ SYMBOL: +wrapped-objects+
[ H{ } +wrapped-objects+ set-global ]
unless
+SYMBOL: +vtbl-counter+
++vtbl-counter+ get-global
+[ 0 +vtbl-counter+ set-global ]
+unless
+
+"windows.com.wrapper.callbacks" create-vocab drop
+
+: (next-vtbl-counter) ( -- n )
+ +vtbl-counter+ [ 1+ dup ] change ;
+
: com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at*
[ "invalid COM wrapping pointer" throw ] unless ;
@@ -22,34 +33,38 @@ unless
[ +wrapped-objects+ get-global delete-at ] keep
free ;
-: (make-query-interface) ( interfaces -- quot )
+: (query-interface-cases) ( interfaces -- cases )
[
- [ swap 16 memory>byte-array ] %
+ [ find-com-interface-definition family-tree [ iid>> ] map ] dip
+ 1quotation [ 2array ] curry map
+ ] map-index concat
+ [ drop f ] suffix ;
+
+: (make-query-interface) ( interfaces -- quot )
+ (query-interface-cases)
+ '[
+ swap 16 memory>byte-array
+ , case
[
- >r find-com-interface-definition family-tree
- r> 1quotation [ >r iid>> r> 2array ] curry map
- ] map-index concat
- [ drop f ] suffix ,
- \ case ,
- "void*" heap-size
- [ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
- curry ,
- [ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
- \ if* ,
- ] [ ] make ;
+ "void*" heap-size * rot <displaced-alien> com-add-ref
+ 0 rot set-void*-nth S_OK
+ ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
+ ] ;
: (make-add-ref) ( interfaces -- quot )
- length "void*" heap-size * [ swap <displaced-alien>
+ length "void*" heap-size * '[
+ , swap <displaced-alien>
0 over ulong-nth
1+ [ 0 rot set-ulong-nth ] keep
- ] curry ;
+ ] ;
: (make-release) ( interfaces -- quot )
- length "void*" heap-size * [ over <displaced-alien>
+ length "void*" heap-size * '[
+ , over <displaced-alien>
0 over ulong-nth
1- [ 0 rot set-ulong-nth ] keep
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
- ] curry ;
+ ] ;
: (make-iunknown-methods) ( interfaces -- quots )
[ (make-query-interface) ]
@@ -60,32 +75,48 @@ unless
: (thunk) ( n -- quot )
dup 0 =
[ drop [ ] ]
- [ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
+ [ "void*" heap-size neg * '[ , swap <displaced-alien> ] ]
if ;
-: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
- [ [ swap 2array ] curry map swap ] keep
- [ com-unwrap ] compose [ swap 2array ] curry map append ;
+: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
+ [ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
+ [ '[ , [ swap 2array ] curry map ] ] bi bi*
+ swap append ;
-: compile-alien-callback ( return parameters abi quot -- alien )
+: compile-alien-callback ( word return parameters abi quot -- alien )
[ alien-callback ] 4 ncurry
- [ gensym [ swap (( -- alien )) define-declared ] keep ]
+ [ [ (( -- alien )) define-declared ] pick slip ]
with-compilation-unit
execute ;
-: (make-vtbl) ( interface-name quots iunknown-methods n -- )
+: (byte-array-to-malloced-buffer) ( byte-array -- alien )
+ [ byte-length malloc ] [ over byte-array>memory ] bi ;
+
+: (callback-word) ( function-name interface-name counter -- word )
+ [ "::" rot 3append "-callback-" ] dip number>string 3append
+ "windows.com.wrapper.callbacks" create ;
+
+: (finish-thunk) ( param-count thunk quot -- thunked-quot )
+ [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
+ dip compose ;
+
+: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
(thunk) (thunked-quots)
- swap find-com-interface-definition family-tree-functions [
- [ return>> ] [ parameters>> [ first ] map ] bi
- dup length 1- roll [
- first dup empty?
- [ 2drop [ ] ]
- [ swap [ ndip ] 2curry ]
- if
- ] [ second ] bi compose
+ swap [ find-com-interface-definition family-tree-functions ]
+ keep (next-vtbl-counter) '[
+ swap [
+ [ name>> , , (callback-word) ]
+ [ return>> ] [
+ parameters>>
+ [ [ first ] map ]
+ [ length ] bi
+ ] tri
+ ] [
+ first2 (finish-thunk)
+ ] bi*
"stdcall" swap compile-alien-callback
- ] 2map >c-void*-array [ byte-length malloc ] keep
- over byte-array>memory ;
+ ] 2map >c-void*-array
+ (byte-array-to-malloced-buffer) ;
: (make-vtbls) ( implementations -- vtbls )
dup [ first ] map (make-iunknown-methods)
@@ -102,11 +133,10 @@ PRIVATE>
: <com-wrapper> ( implementations -- wrapper )
(make-vtbls) f com-wrapper boa ;
-M: com-wrapper dispose
- t >>freed?
+M: com-wrapper dispose*
vtbls>> [ free ] each ;
: com-wrap ( object wrapper -- wrapped-object )
- dup (malloc-wrapped-object) >r vtbls>> r>
+ [ vtbls>> ] [ (malloc-wrapped-object) ] bi
[ [ set-void*-nth ] curry each-index ] keep
[ +wrapped-objects+ get-global set-at ] keep ;
From f508f57fa06aed9e6bd58aaf471a2ecbc828d19c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 13 Jun 2008 01:17:10 -0500
Subject: [PATCH 09/90] add create-index
---
extra/db/queries/queries.factor | 9 +++++++++
1 file changed, 9 insertions(+)
diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index 807aeda74a..5c3f3e13e6 100644
--- a/extra/db/queries/queries.factor
+++ b/extra/db/queries/queries.factor
@@ -195,3 +195,12 @@ M: db <count-statement> ( tuple class groups -- statement )
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
+
+: create-index ( index-name table-name columns -- )
+ [
+ >r >r "create index " % % r> " on " % % r> "(" %
+ "," join % ")" %
+ ] "" make sql-command ;
+
+: drop-index ( index-name -- )
+ [ "drop index " % % ] "" make sql-command ;
From 045b657474f819a63243bd4c412f5ea93ea3119a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 01:51:46 -0500
Subject: [PATCH 10/90] Move replicate into core; move selection sort into its
own vocab; remove usages of and? and or? which are redundant now
---
core/bit-arrays/bit-arrays-tests.factor | 2 +-
core/classes/algebra/algebra-tests.factor | 6 +++---
core/inference/backend/backend.factor | 6 +++---
core/sequences/sequences.factor | 6 ++++++
core/sorting/sorting-tests.factor | 2 +-
core/strings/strings-tests.factor | 2 +-
core/vectors/vectors-tests.factor | 2 +-
extra/color-picker/color-picker.factor | 2 +-
extra/delegate/delegate.factor | 14 +++++++++++---
extra/io/files/unique/unique.factor | 2 +-
extra/io/pipes/pipes.factor | 2 +-
extra/koszul/koszul.factor | 2 +-
extra/lcs/lcs-tests.factor | 4 ++++
extra/lcs/lcs.factor | 12 ++++++++----
extra/project-euler/150/150.factor | 5 +----
extra/sequences/lib/lib.factor | 18 ------------------
extra/sorting/insertion/authors.txt | 1 +
extra/sorting/insertion/insertion.factor | 16 ++++++++++++++++
extra/sorting/insertion/summary.txt | 1 +
extra/sorting/insertion/tags.txt | 1 +
extra/state-parser/state-parser.factor | 2 +-
extra/strings/lib/lib-tests.factor | 2 +-
extra/strings/lib/lib.factor | 3 +--
extra/ui/gadgets/frames/frames.factor | 2 +-
extra/unicode/breaks/breaks.factor | 5 ++---
extra/unicode/collation/collation.factor | 3 +--
extra/unicode/data/data.factor | 4 ++--
extra/unicode/normalize/normalize.factor | 2 +-
extra/webapps/wee-url/wee-url.factor | 2 +-
29 files changed, 74 insertions(+), 57 deletions(-)
create mode 100644 extra/sorting/insertion/authors.txt
create mode 100644 extra/sorting/insertion/insertion.factor
create mode 100644 extra/sorting/insertion/summary.txt
create mode 100644 extra/sorting/insertion/tags.txt
diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor
index 03961c2db6..b41cf9c4a5 100755
--- a/core/bit-arrays/bit-arrays-tests.factor
+++ b/core/bit-arrays/bit-arrays-tests.factor
@@ -38,7 +38,7 @@ IN: bit-arrays.tests
[ t ] [
100 [
- drop 100 [ drop 2 random zero? ] map
+ drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
] all?
] unit-test
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index 28e899d08b..05c254f225 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -204,7 +204,7 @@ UNION: z1 b1 c1 ;
10 [
[ ] [
- 20 [ drop random-op ] map >quotation
+ 20 [ random-op ] [ ] replicate-as
[ infer effect-in [ random-class ] times ] keep
call
drop
@@ -238,8 +238,8 @@ UNION: z1 b1 c1 ;
20 [
[ t ] [
- 20 [ drop random-boolean-op ] [ ] map-as dup .
- [ infer effect-in [ drop random-boolean ] map dup . ] keep
+ 20 [ random-boolean-op ] [ ] replicate-as dup .
+ [ infer effect-in [ random-boolean ] replicate dup . ] keep
[ >r [ ] each r> call ] 2keep
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 8966a38496..f8b071e803 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ;
1 #drop node,
pop-d dup value-literal >r value-recursion r> ;
-: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
+: value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
: add-inputs ( seq stack -- n stack )
tuck [ length ] bi@ - dup 0 >
@@ -162,7 +162,7 @@ TUPLE: too-many-r> ;
dup ensure-values
#>r
over 0 pick node-inputs
- over [ drop pop-d ] map reverse [ push-r ] each
+ over [ pop-d ] replicate reverse [ push-r ] each
0 pick pick node-outputs
node,
drop ;
@@ -171,7 +171,7 @@ TUPLE: too-many-r> ;
dup check-r>
#r>
0 pick pick node-inputs
- over [ drop pop-r ] map reverse [ push-d ] each
+ over [ pop-r ] replicate reverse [ push-d ] each
over 0 pick node-outputs
node,
drop ;
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 4854ff8001..cb33552693 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -361,6 +361,12 @@ PRIVATE>
: map ( seq quot -- newseq )
over map-as ; inline
+: replicate ( seq quot -- newseq )
+ [ drop ] prepose map ; inline
+
+: replicate-as ( seq quot exemplar -- newseq )
+ >r [ drop ] prepose r> map-as ; inline
+
: change-each ( seq quot -- )
over map-into ; inline
diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor
index a56c41b620..17ec2d7cd1 100755
--- a/core/sorting/sorting-tests.factor
+++ b/core/sorting/sorting-tests.factor
@@ -11,7 +11,7 @@ unit-test
[ t ] [
100 [
drop
- 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic?
+ 100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
] all?
] unit-test
diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor
index 44e1d8859f..d10f1603f1 100755
--- a/core/strings/strings-tests.factor
+++ b/core/strings/strings-tests.factor
@@ -98,7 +98,7 @@ unit-test
[ ] [
[
4 [
- 100 [ drop "obdurak" clone ] map
+ 100 [ "obdurak" clone ] replicate
gc
dup [
1234 0 rot set-string-nth
diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor
index 8f64265771..7f4abe3222 100755
--- a/core/vectors/vectors-tests.factor
+++ b/core/vectors/vectors-tests.factor
@@ -26,7 +26,7 @@ IN: vectors.tests
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
[ t ] [
- 100 [ drop 100 random ] map >vector
+ 100 [ 100 random ] V{ } map-as
dup >array >vector =
] unit-test
diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
index 0480235dfe..c64d1e4872 100755
--- a/extra/color-picker/color-picker.factor
+++ b/extra/color-picker/color-picker.factor
@@ -24,7 +24,7 @@ M: color-preview model-changed
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
- 3 [ drop 0 0 0 255 <range> ] map
+ 3 [ 0 0 0 255 <range> ] replicate
dup [ range-model ] map <compose>
swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index c375dcf874..4f1e950b01 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs
-sequences arrays vectors definitions prettyprint combinators.lib
-math hashtables sets ;
+sequences arrays vectors definitions prettyprint
+math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )
@@ -23,7 +23,15 @@ M: tuple-class group-words
: consult-method ( word class quot -- )
[ drop swap first create-method ]
- [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi
+ [
+ nip
+ [
+ over second saver %
+ %
+ dup second restorer %
+ first ,
+ ] [ ] make
+ ] 3bi
define ;
: change-word-prop ( word prop quot -- )
diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor
index 06a3ec8dd2..3efef66ae3 100644
--- a/extra/io/files/unique/unique.factor
+++ b/extra/io/files/unique/unique.factor
@@ -15,7 +15,7 @@ IN: io.files.unique
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( n -- string )
- [ drop random-ch ] "" map-as ;
+ [ random-ch ] "" replicate-as ;
: unique-length ( -- n ) 10 ; inline
: unique-retries ( -- n ) 10 ; inline
diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor
index b519752e79..72beb473ed 100644
--- a/extra/io/pipes/pipes.factor
+++ b/extra/io/pipes/pipes.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.ports io.streams.duplex
-io splitting grouping sequences sequences.lib namespaces kernel
+io splitting grouping sequences namespaces kernel
destructors math concurrency.combinators accessors
arrays continuations quotations ;
IN: io.pipes
diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor
index 7b636609b0..b56473a0a9 100755
--- a/extra/koszul/koszul.factor
+++ b/extra/koszul/koszul.factor
@@ -142,7 +142,7 @@ DEFER: (d)
! Computing a basis
: graded ( seq -- seq )
- dup 0 [ length max ] reduce 1+ [ drop V{ } clone ] map
+ dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
diff --git a/extra/lcs/lcs-tests.factor b/extra/lcs/lcs-tests.factor
index 3aa10a0687..7d9a9ffd27 100755
--- a/extra/lcs/lcs-tests.factor
+++ b/extra/lcs/lcs-tests.factor
@@ -2,6 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
+\ lcs must-infer
+\ diff must-infer
+\ levenshtein must-infer
+
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor
index 06c33505ca..4b0fb53f5e 100755
--- a/extra/lcs/lcs.factor
+++ b/extra/lcs/lcs.factor
@@ -63,15 +63,19 @@ TUPLE: trace-state old new table i j ;
[ 1- ] change-i [ 1- ] change-j ;
: inserted? ( state -- ? )
- [ j>> 0 > ]
- [ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;
+ {
+ [ j>> 0 > ]
+ [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]
+ } 1&& ;
: do-insert ( state -- state )
dup new-nth insert boa , [ 1- ] change-j ;
: deleted? ( state -- ? )
- [ i>> 0 > ]
- [ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;
+ {
+ [ i>> 0 > ]
+ [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]
+ } 1&& ;
: do-delete ( state -- state )
dup old-nth delete boa , [ 1- ] change-i ;
diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor
index 8c93d4f7e6..49de5dbc03 100644
--- a/extra/project-euler/150/150.factor
+++ b/extra/project-euler/150/150.factor
@@ -17,9 +17,6 @@ IN: project-euler.150
: partial-sum-infimum ( seq -- seq )
0 0 rot [ (partial-sum-infimum) ] each drop ; inline
-: generate ( n quot -- seq )
- [ drop ] prepose map ; inline
-
: map-infimum ( seq quot -- min )
[ min ] compose 0 swap reduce ; inline
@@ -30,7 +27,7 @@ IN: project-euler.150
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
- 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
+ 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
PRIVATE>
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 265cd5b592..ed4c337a92 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -131,10 +131,6 @@ MACRO: firstn ( n -- )
[ find drop [ head-slice ] when* ] curry
[ dup ] prepose keep like ;
-: replicate ( seq quot -- newseq )
- #! quot: ( -- obj )
- [ drop ] prepose map ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
@@ -244,20 +240,6 @@ PRIVATE>
: short ( seq n -- seq n' )
over length min ; inline
-<PRIVATE
-:: insert ( seq quot n -- )
- n zero? [
- n n 1- [ seq nth quot call ] bi@ >= [
- n n 1- seq exchange
- seq quot n 1- insert
- ] unless
- ] unless ; inline
-PRIVATE>
-
-: insertion-sort ( seq quot -- )
- ! quot is a transformation on elements
- over length [ insert ] 2with each ; inline
-
: if-seq ( seq quot1 quot2 -- )
[ f like ] 2dip if* ; inline
diff --git a/extra/sorting/insertion/authors.txt b/extra/sorting/insertion/authors.txt
new file mode 100644
index 0000000000..f990dd0ed2
--- /dev/null
+++ b/extra/sorting/insertion/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/extra/sorting/insertion/insertion.factor b/extra/sorting/insertion/insertion.factor
new file mode 100644
index 0000000000..3a46eb83fd
--- /dev/null
+++ b/extra/sorting/insertion/insertion.factor
@@ -0,0 +1,16 @@
+USING: locals sequences kernel math ;
+IN: sorting.insertion
+
+<PRIVATE
+:: insert ( seq quot n -- )
+ n zero? [
+ n n 1- [ seq nth quot call ] bi@ >= [
+ n n 1- seq exchange
+ seq quot n 1- insert
+ ] unless
+ ] unless ; inline
+PRIVATE>
+
+: insertion-sort ( seq quot -- )
+ ! quot is a transformation on elements
+ over length [ insert ] with with each ; inline
diff --git a/extra/sorting/insertion/summary.txt b/extra/sorting/insertion/summary.txt
new file mode 100644
index 0000000000..a71be797d9
--- /dev/null
+++ b/extra/sorting/insertion/summary.txt
@@ -0,0 +1 @@
+Insertion sort
diff --git a/extra/sorting/insertion/tags.txt b/extra/sorting/insertion/tags.txt
new file mode 100644
index 0000000000..42d711b32b
--- /dev/null
+++ b/extra/sorting/insertion/tags.txt
@@ -0,0 +1 @@
+collections
diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor
index af005b4abe..1feaf46017 100644
--- a/extra/state-parser/state-parser.factor
+++ b/extra/state-parser/state-parser.factor
@@ -144,7 +144,7 @@ M: not-enough-characters summary ( obj -- str )
] if next ;
: expect-string ( string -- )
- dup [ drop get-char next ] map 2dup =
+ dup [ get-char next ] replicate 2dup =
[ 2drop ] [ expected ] if ;
: init-parser ( -- )
diff --git a/extra/strings/lib/lib-tests.factor b/extra/strings/lib/lib-tests.factor
index 2779e190c9..6e0ce05eaa 100644
--- a/extra/strings/lib/lib-tests.factor
+++ b/extra/strings/lib/lib-tests.factor
@@ -5,4 +5,4 @@ IN: temporary
[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
-[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test
+[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test
diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor
index e1d88e479d..6ecca05ec8 100644
--- a/extra/strings/lib/lib.factor
+++ b/extra/strings/lib/lib.factor
@@ -30,5 +30,4 @@ IN: strings.lib
alphanumeric-chars random ;
: random-alphanumeric-string ( length -- str )
- [ drop random-alphanumeric-char ] map "" like ;
-
+ [ random-alphanumeric-char ] "" replicate-as ;
diff --git a/extra/ui/gadgets/frames/frames.factor b/extra/ui/gadgets/frames/frames.factor
index 3e38f60627..c0fe59a529 100644
--- a/extra/ui/gadgets/frames/frames.factor
+++ b/extra/ui/gadgets/frames/frames.factor
@@ -8,7 +8,7 @@ IN: ui.gadgets.frames
! gadgets gets left-over space.
TUPLE: frame ;
-: <frame-grid> ( -- grid ) 9 [ drop <gadget> ] map 3 group ;
+: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
: @center 1 1 ;
: @left 0 1 ;
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index 23dfc16e78..b70d79b872 100755
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -23,8 +23,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? )
- [ (extend)? ]
- [ "Other_Grapheme_Extend" property? ] or? ;
+ { [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ;
: grapheme-class ( ch -- class )
{
@@ -35,7 +34,7 @@ CATEGORY: (extend) Me Mn ;
} cond ;
: init-grapheme-table ( -- table )
- graphemes [ drop graphemes f <array> ] map ;
+ graphemes [ graphemes f <array> ] replicate ;
SYMBOL: table
diff --git a/extra/unicode/collation/collation.factor b/extra/unicode/collation/collation.factor
index f71a58be85..216f80c79d 100755
--- a/extra/unicode/collation/collation.factor
+++ b/extra/unicode/collation/collation.factor
@@ -58,8 +58,7 @@ ducet insert-helpers
HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;
: illegal? ( char -- ? )
- [ "Noncharacter_Code_Point" property? ]
- [ category "Cs" = ] or? ;
+ { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;
: derive-weight ( char -- weights )
first dup illegal?
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index e3dd15558b..8ef8658adb 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -62,7 +62,7 @@ VALUE: properties
dup [ swap (chain-decomposed) ] curry assoc-map ;
: first* ( seq -- ? )
- second [ empty? ] [ first ] or? ;
+ second { [ empty? ] [ first ] } 1|| ;
: (process-decomposed) ( data -- alist )
5 swap (process-data)
@@ -107,7 +107,7 @@ VALUE: properties
:: fill-ranges ( table -- table )
name-map >alist sort-values keys
- [ [ "first>" tail? ] [ "last>" tail? ] or? ] filter
+ [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
2 group [
[ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
[ swap table ?set-nth ] curry each
diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor
index 576c5a7e20..3b64cf577f 100755
--- a/extra/unicode/normalize/normalize.factor
+++ b/extra/unicode/normalize/normalize.factor
@@ -1,5 +1,5 @@
USING: sequences namespaces unicode.data kernel math arrays
-locals combinators.lib sequences.lib combinators.lib ;
+locals combinators.lib sorting.insertion combinators.lib ;
IN: unicode.normalize
! Conjoining Jamo behavior
diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor
index afdacf9add..d408c645f3 100644
--- a/extra/webapps/wee-url/wee-url.factor
+++ b/extra/webapps/wee-url/wee-url.factor
@@ -26,7 +26,7 @@ short-url "SHORT_URLS" {
3append ; foldable
: random-url ( -- string )
- 1 6 [a,b] random [ drop letter-bank random ] "" map-as ;
+ 1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
: insert-short-url ( short-url -- short-url )
'[ , dup random-url >>short insert-tuple ] 10 retry ;
From 375020b7fe9d46bc9831a4f8790e5c3ae59be4be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 02:09:16 -0500
Subject: [PATCH 11/90] Add push-at to core
---
core/assocs/assocs.factor | 3 +++
core/optimizer/def-use/def-use.factor | 5 ++---
extra/assocs/lib/lib.factor | 5 +----
extra/gap-buffer/cursortree/cursortree.factor | 4 ++--
extra/help/lint/lint.factor | 2 +-
extra/io/unix/backend/backend.factor | 7 ++-----
extra/unicode/data/data.factor | 4 ++--
extra/xmode/rules/rules.factor | 2 +-
8 files changed, 14 insertions(+), 18 deletions(-)
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index ca49b550b0..c875475278 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
+: push-at ( value key assoc -- )
+ [ ?push ] change-at ;
+
: zip ( keys values -- alist )
2array flip ; inline
diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor
index a2e9f88135..d4905a1718 100755
--- a/core/optimizer/def-use/def-use.factor
+++ b/core/optimizer/def-use/def-use.factor
@@ -13,7 +13,7 @@ SYMBOL: def-use
used-by empty? ;
: uses-values ( node seq -- )
- [ def-use get [ ?push ] change-at ] with each ;
+ [ def-use get push-at ] with each ;
: defs-values ( seq -- )
#! If there is no value, set it to a new empty vector,
@@ -132,5 +132,4 @@ M: #r> kill-node*
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
- nest-def-use keys
- def-use get [ [ t swap ?push ] change-at ] curry each ;
+ nest-def-use keys def-use get [ t -rot push-at ] curry each ;
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index c3e487a9fc..1c89c1eb16 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -17,9 +17,6 @@ IN: assocs.lib
: replace-at ( assoc value key -- assoc )
>r >r dup r> 1vector r> rot set-at ;
-: insert-at ( value key assoc -- )
- [ ?push ] change-at ;
-
: peek-at* ( assoc key -- obj ? )
swap at* dup [ >r peek r> ] when ;
@@ -32,7 +29,7 @@ IN: assocs.lib
: multi-assoc-each ( assoc quot -- )
[ with each ] curry assoc-each ; inline
-: insert ( value variable -- ) namespace insert-at ;
+: insert ( value variable -- ) namespace push-at ;
: generate-key ( assoc -- str )
>r 32 random-bits >hex r>
diff --git a/extra/gap-buffer/cursortree/cursortree.factor b/extra/gap-buffer/cursortree/cursortree.factor
index a3a5075820..4249aea2d9 100644
--- a/extra/gap-buffer/cursortree/cursortree.factor
+++ b/extra/gap-buffer/cursortree/cursortree.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math
+USING: assocs kernel gap-buffer generic trees trees.avl math
sequences quotations ;
IN: gap-buffer.cursortree
@@ -21,7 +21,7 @@ TUPLE: right-cursor ;
: cursor-index ( cursor -- i ) cursor-i ;
-: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ;
+: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ;
: remove-cursor ( cursortree cursor -- )
tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor
index 00a8e287e6..eef2463019 100755
--- a/extra/help/lint/lint.factor
+++ b/extra/help/lint/lint.factor
@@ -114,7 +114,7 @@ M: help-error error.
H{ } clone [
[
>r >r dup >link where dup
- [ first r> at r> [ ?push ] change-at ]
+ [ first r> at r> push-at ]
[ r> r> 2drop 2drop ]
if
] 2curry each
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 67856a0570..8e76be2632 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -44,14 +44,11 @@ TUPLE: mx fd reads writes ;
GENERIC: add-input-callback ( thread fd mx -- )
-: add-callback ( thread fd assoc -- )
- [ ?push ] change-at ;
-
-M: mx add-input-callback reads>> add-callback ;
+M: mx add-input-callback reads>> push-at ;
GENERIC: add-output-callback ( thread fd mx -- )
-M: mx add-output-callback writes>> add-callback ;
+M: mx add-output-callback writes>> push-at ;
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index 8ef8658adb..5fb769e499 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,7 +1,7 @@
USING: assocs math kernel sequences io.files hashtables
quotations splitting grouping arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser
-io.encodings.ascii values interval-maps ascii sets assocs.lib
+io.encodings.ascii values interval-maps ascii sets
combinators.lib combinators locals math.ranges sorting ;
IN: unicode.data
@@ -151,7 +151,7 @@ C: <code-point> code-point
: properties>intervals ( properties -- assoc[str,interval] )
dup values prune [ f ] H{ } map>assoc
- [ [ insert-at ] curry assoc-each ] keep
+ [ [ push-at ] curry assoc-each ] keep
[ <interval-set> ] assoc-map ;
: load-properties ( -- assoc )
diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor
index df5580fc68..daaeac70a4 100755
--- a/extra/xmode/rules/rules.factor
+++ b/extra/xmode/rules/rules.factor
@@ -42,7 +42,7 @@ MEMO: standard-rule-set ( id -- ruleset )
rule-set-imports push ;
: inverted-index ( hashes key index -- )
- [ swapd [ ?push ] change-at ] 2curry each ;
+ [ swapd push-at ] 2curry each ;
: ?push-all ( seq1 seq2 -- seq1+seq2 )
[
From fbd799f0a201246b2fbf6a98839a569d3f0b5f3c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 02:14:35 -0500
Subject: [PATCH 12/90] Fix test failures
---
extra/html/templates/chloe/chloe-tests.factor | 2 +-
extra/io/server/server-tests.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor
index 6ca596f503..433aedbc9a 100644
--- a/extra/html/templates/chloe/chloe-tests.factor
+++ b/extra/html/templates/chloe/chloe-tests.factor
@@ -151,7 +151,7 @@ TUPLE: person first-name last-name ;
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
-[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
+[ "<form method='post' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
[
"test10" test-template call-template
] run-template
diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor
index 86cfe35bc1..965a70718b 100755
--- a/extra/io/server/server-tests.factor
+++ b/extra/io/server/server-tests.factor
@@ -2,6 +2,6 @@ IN: io.server.tests
USING: tools.test io.server io.server.private kernel ;
{ 2 0 } [ [ ] server-loop ] must-infer-as
-{ 2 0 } [ [ ] with-connection ] must-infer-as
+{ 3 0 } [ [ ] with-connection ] must-infer-as
{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
{ 2 0 } [ [ ] with-datagrams ] must-infer-as
From 3fa97aa1716d43a5a5a9974ad83927a6e242d452 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 13 Jun 2008 03:40:51 -0500
Subject: [PATCH 13/90] combinators.lib: remove old words
---
extra/combinators/lib/lib.factor | 26 --------------------------
1 file changed, 26 deletions(-)
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index da13901ab7..fe6b68638b 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -66,32 +66,6 @@ MACRO: napply ( n -- )
: short-circuit ( quots quot default -- quot )
1quotation -rot { } map>assoc <reversed> alist>quot ;
-! MACRO: && ( quots -- ? )
-! [ [ not ] append [ f ] ] t short-circuit ;
-
-! MACRO: <-&& ( quots -- )
-! [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit
-! [ nip ] append ;
-
-! MACRO: <--&& ( quots -- )
-! [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
-! [ 2nip ] append ;
-
-! or
-
-! MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
-
-! MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
-
-! MACRO: 1|| ( quots -- ? )
-! [ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
-
-! MACRO: 2|| ( quots -- ? )
-! [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
-
-! MACRO: 3|| ( quots -- ? )
-! [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: 0&& ( quots -- quot )
From 01c3a185b85c138397a9e29fefc4ee2dd21847b0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 15:35:40 -0500
Subject: [PATCH 14/90] Fixing tests
---
core/vectors/vectors-tests.factor | 2 +-
extra/sequences/lib/lib-tests.factor | 1 -
extra/sorting/insertion/insertion-tests.factor | 4 ++++
3 files changed, 5 insertions(+), 2 deletions(-)
create mode 100644 extra/sorting/insertion/insertion-tests.factor
diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor
index 7f4abe3222..3b2c94b2e5 100755
--- a/core/vectors/vectors-tests.factor
+++ b/core/vectors/vectors-tests.factor
@@ -26,7 +26,7 @@ IN: vectors.tests
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
[ t ] [
- 100 [ 100 random ] V{ } map-as
+ 100 [ 100 random ] V{ } replicate-as
dup >array >vector =
] unit-test
diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor
index ee447decdf..019796c1a1 100755
--- a/extra/sequences/lib/lib-tests.factor
+++ b/extra/sequences/lib/lib-tests.factor
@@ -80,7 +80,6 @@ IN: sequences.lib.tests
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test
-[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test
[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
diff --git a/extra/sorting/insertion/insertion-tests.factor b/extra/sorting/insertion/insertion-tests.factor
new file mode 100644
index 0000000000..38b0082ade
--- /dev/null
+++ b/extra/sorting/insertion/insertion-tests.factor
@@ -0,0 +1,4 @@
+IN: sorting.insertion
+USING: sorting.insertion sequences kernel tools.test ;
+
+[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test
From a949c1038745f34e43716e52d69f7b588bc8bfcd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 20:54:31 -0500
Subject: [PATCH 15/90] Minor DB cleanup, add an ensure-tables word
---
extra/db/sqlite/sqlite.factor | 2 +-
extra/db/tuples/tuples.factor | 3 +++
2 files changed, 4 insertions(+), 1 deletion(-)
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index c7c9065b43..38a3899fc4 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -53,7 +53,7 @@ M: sqlite-result-set dispose ( result-set -- )
M: sqlite-statement low-level-bind ( statement -- )
[ statement-bind-params ] [ statement-handle ] bi
- swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
+ [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 4903adff5c..e02e21cbe6 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -122,6 +122,9 @@ M: retryable execute-statement* ( statement type -- )
: ensure-table ( class -- )
[ create-table ] curry ignore-errors ;
+: ensure-tables ( classes -- )
+ [ ensure-table ] each ;
+
: insert-db-assigned-statement ( tuple -- )
dup class
db get db-insert-statements [ <insert-db-assigned-statement> ] cache
From e7b786ecfa9ea6448df3d1ee747cb3d2d21a6df6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 20:54:52 -0500
Subject: [PATCH 16/90] New furnace.alloy vocab makes things easier; add
expiration for asides and flash scopes
---
extra/furnace/alloy/alloy.factor | 24 +++++++
extra/furnace/asides/asides.factor | 64 +++++++++++++------
.../furnace/auth/providers/db/db-tests.factor | 2 +-
extra/furnace/auth/providers/db/db.factor | 2 -
extra/furnace/cache/cache.factor | 36 +++++++++++
extra/furnace/flash/flash.factor | 53 ++++++++++-----
extra/furnace/sessions/sessions-tests.factor | 4 +-
extra/furnace/sessions/sessions.factor | 34 +++-------
extra/http/http-tests.factor | 8 +--
extra/http/server/server.factor | 4 +-
.../persistent-vectors-tests.factor | 2 +-
extra/webapps/blogs/blogs.factor | 4 --
.../factor-website/factor-website.factor | 34 ++++------
extra/webapps/pastebin/pastebin.factor | 4 --
extra/webapps/planet/planet.factor | 4 --
extra/webapps/todo/todo.factor | 2 -
extra/webapps/wee-url/wee-url.factor | 3 -
extra/webapps/wiki/wiki.factor | 4 --
18 files changed, 171 insertions(+), 117 deletions(-)
create mode 100644 extra/furnace/alloy/alloy.factor
create mode 100644 extra/furnace/cache/cache.factor
diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor
new file mode 100644
index 0000000000..24b47cc4b8
--- /dev/null
+++ b/extra/furnace/alloy/alloy.factor
@@ -0,0 +1,24 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences db.tuples alarms calendar db fry
+furnace.cache
+furnace.asides
+furnace.flash
+furnace.sessions
+furnace.db
+furnace.auth.providers ;
+IN: furnace.alloy
+
+: <alloy> ( responder db params -- responder' )
+ [ <asides> <flash-scopes> <sessions> ] 2dip <db-persistence> ;
+
+: state-classes { session flash-scope aside } ; inline
+
+: init-furnace-tables ( -- )
+ state-classes ensure-tables
+ user ensure-table ;
+
+: start-expiring ( db params -- )
+ '[
+ , , [ state-classes [ expire-state ] each ] with-db
+ ] 5 minutes every drop ;
diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor
index f6b4e2c15f..fc767e050d 100644
--- a/extra/furnace/asides/asides.factor
+++ b/extra/furnace/asides/asides.factor
@@ -2,37 +2,60 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces sequences arrays kernel
assocs assocs.lib hashtables math.parser urls combinators
-furnace http http.server http.server.filters furnace.sessions
-html.elements html.templates.chloe.syntax ;
+html.elements html.templates.chloe.syntax db.types db.tuples
+http http.server http.server.filters
+furnace furnace.cache furnace.sessions ;
IN: furnace.asides
-TUPLE: asides < filter-responder ;
+TUPLE: aside < server-state session method url post-data ;
-C: <asides> asides
+: <aside> ( id -- aside )
+ aside new-server-state ;
+
+aside "ASIDES"
+{
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "method" "METHOD" { VARCHAR 10 } +not-null+ }
+ { "url" "URL" URL +not-null+ }
+ { "post-data" "POST_DATA" FACTOR-BLOB }
+} define-persistent
+
+TUPLE: asides < server-state-manager ;
+
+: <asides> ( responder -- responder' )
+ asides new-server-state-manager ;
: begin-aside* ( -- id )
- request get
- [ url>> ] [ post-data>> ] [ method>> ] tri 3array
- asides sget set-at-unique
- session-changed ;
+ f <aside>
+ session get id>> >>session
+ request get
+ [ method>> >>method ]
+ [ url>> >>url ]
+ [ post-data>> >>post-data ]
+ tri
+ [ asides get touch-state ] [ insert-tuple ] [ id>> ] tri ;
-: end-aside-post ( url post-data -- response )
+: end-aside-post ( aside -- response )
request [
clone
- swap >>post-data
- swap >>url
+ over post-data>> >>post-data
+ over url>> >>url
] change
- request get url>> path>> split-path
+ url>> path>> split-path
asides get responder>> call-responder ;
ERROR: end-aside-in-get-error ;
+: get-aside ( id -- aside )
+ dup [ aside get-state ] when
+ dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+
: end-aside* ( url id -- response )
request get method>> "POST" = [ end-aside-in-get-error ] unless
- asides sget at [
- first3 {
- { "GET" [ drop <redirect> ] }
- { "HEAD" [ drop <redirect> ] }
+ aside get-state [
+ dup method>> {
+ { "GET" [ url>> <redirect> ] }
+ { "HEAD" [ url>> <redirect> ] }
{ "POST" [ end-aside-post ] }
} case
] [ <redirect> ] ?if ;
@@ -47,13 +70,12 @@ SYMBOL: aside-id
: end-aside ( default -- response )
aside-id [ f ] change end-aside* ;
+: request-aside-id ( request -- aside-id )
+ aside-id-key swap request-params at string>number ;
+
M: asides call-responder*
dup asides set
- aside-id-key request get request-params at aside-id set
- call-next-method ;
-
-M: asides init-session*
- H{ } clone asides sset
+ request get request-aside-id aside-id set
call-next-method ;
M: asides link-attr ( tag -- )
diff --git a/extra/furnace/auth/providers/db/db-tests.factor b/extra/furnace/auth/providers/db/db-tests.factor
index 714dcb416f..e5914c7ab3 100755
--- a/extra/furnace/auth/providers/db/db-tests.factor
+++ b/extra/furnace/auth/providers/db/db-tests.factor
@@ -14,7 +14,7 @@ login set
"auth-test.db" temp-file sqlite-db [
- init-users-table
+ user ensure-table
[ t ] [
"slava" <user>
diff --git a/extra/furnace/auth/providers/db/db.factor b/extra/furnace/auth/providers/db/db.factor
index 66c1b3ec99..72eb0d462a 100755
--- a/extra/furnace/auth/providers/db/db.factor
+++ b/extra/furnace/auth/providers/db/db.factor
@@ -18,8 +18,6 @@ user "USERS"
{ "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent
-: init-users-table ( -- ) user ensure-table ;
-
SINGLETON: users-in-db
M: users-in-db get-user
diff --git a/extra/furnace/cache/cache.factor b/extra/furnace/cache/cache.factor
new file mode 100644
index 0000000000..a614a52548
--- /dev/null
+++ b/extra/furnace/cache/cache.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math.intervals
+calendar alarms fry
+random db db.tuples db.types
+http.server.filters ;
+IN: furnace.cache
+
+TUPLE: server-state id expires ;
+
+: new-server-state ( id class -- server-state )
+ new swap >>id ; inline
+
+server-state f
+{
+ { "id" "ID" +random-id+ system-random-generator }
+ { "expires" "EXPIRES" TIMESTAMP +not-null+ }
+} define-persistent
+
+: get-state ( id class -- state )
+ new-server-state select-tuple ;
+
+: expire-state ( class -- )
+ new
+ -1.0/0.0 now [a,b] >>expires
+ delete-tuples ;
+
+TUPLE: server-state-manager < filter-responder timeout ;
+
+: new-server-state-manager ( responder class -- responder' )
+ new
+ swap >>responder
+ 20 minutes >>timeout ; inline
+
+: touch-state ( state manager -- )
+ timeout>> from-now >>expires drop ;
diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor
index 21fd20ccb4..43e0d293a5 100644
--- a/extra/furnace/flash/flash.factor
+++ b/extra/furnace/flash/flash.factor
@@ -1,38 +1,59 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs assocs.lib kernel sequences urls
+USING: namespaces assocs assocs.lib kernel sequences accessors
+urls db.types db.tuples math.parser fry
http http.server http.server.filters http.server.redirection
-furnace furnace.sessions ;
+furnace furnace.cache furnace.sessions ;
IN: furnace.flash
+TUPLE: flash-scope < server-state session namespace ;
+
+: <flash-scope> ( id -- aside )
+ flash-scope new-server-state ;
+
+flash-scope "FLASH_SCOPES" {
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+} define-persistent
+
: flash-id-key "__f" ;
-TUPLE: flash-scopes < filter-responder ;
+TUPLE: flash-scopes < server-state-manager ;
-C: <flash-scopes> flash-scopes
+: <flash-scopes> ( responder -- responder' )
+ flash-scopes new-server-state-manager ;
SYMBOL: flash-scope
: fget ( key -- value ) flash-scope get at ;
-M: flash-scopes call-responder*
- flash-id-key
- request get request-params at
- flash-scopes sget at flash-scope set
- call-next-method ;
+: get-flash-scope ( id -- flash-scope )
+ dup [ flash-scope get-state ] when
+ dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
-M: flash-scopes init-session*
- H{ } clone flash-scopes sset
+: request-flash-scope ( request -- flash-scope )
+ flash-id-key swap request-params at string>number get-flash-scope ;
+
+M: flash-scopes call-responder*
+ dup flash-scopes set
+ request get request-flash-scope flash-scope set
call-next-method ;
: make-flash-scope ( seq -- id )
- [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
- session-changed ;
+ f <flash-scope>
+ session get id>> >>session
+ swap [ dup get ] H{ } map>assoc >>namespace
+ [ flash-scopes get touch-state ] [ insert-tuple ] [ id>> ] tri ;
: <flash-redirect> ( url seq -- response )
- make-flash-scope
- [ clone ] dip flash-id-key set-query-param
+ [ clone ] dip
+ make-flash-scope flash-id-key set-query-param
<redirect> ;
: restore-flash ( seq -- )
- [ flash-scope get key? ] filter [ [ fget ] keep set ] each ;
+ flash-scope get dup [
+ namespace>>
+ [ '[ , key? ] filter ]
+ [ '[ [ , at ] keep set ] each ]
+ bi
+ ] [ 2drop ] if ;
diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor
index a7a663ffa8..e203a6fd40 100755
--- a/extra/furnace/sessions/sessions-tests.factor
+++ b/extra/furnace/sessions/sessions-tests.factor
@@ -3,7 +3,7 @@ USING: tools.test http furnace.sessions
furnace.actions http.server http.server.responses
math namespaces kernel accessors
prettyprint io.streams.string io.files splitting destructors
-sequences db db.sqlite continuations urls math.parser
+sequences db db.tuples db.sqlite continuations urls math.parser
furnace ;
: with-session
@@ -54,7 +54,7 @@ M: foo call-responder*
"auth-test.db" temp-file sqlite-db [
<request> init-request
- init-sessions-table
+ session ensure-table
[ ] [
<foo> <sessions>
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index b046ee40eb..0c0788a1e6 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -5,36 +5,23 @@ random accessors quotations hashtables sequences continuations
fry calendar combinators destructors alarms
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
-html.elements furnace ;
+html.elements
+furnace furnace.cache ;
IN: furnace.sessions
-TUPLE: session id expires uid namespace changed? ;
+TUPLE: session < server-state uid namespace changed? ;
: <session> ( id -- session )
- session new
- swap >>id ;
+ session new-server-state ;
session "SESSIONS"
{
- { "id" "ID" +random-id+ system-random-generator }
- { "expires" "EXPIRES" TIMESTAMP +not-null+ }
{ "uid" "UID" { VARCHAR 255 } }
- { "namespace" "NAMESPACE" FACTOR-BLOB }
+ { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
} define-persistent
: get-session ( id -- session )
- dup [ <session> select-tuple ] when ;
-
-: init-sessions-table ( -- ) session ensure-table ;
-
-: start-expiring-sessions ( db seq -- )
- '[
- , , [
- session new
- -1.0/0.0 now [a,b] >>expires
- delete-tuples
- ] with-db
- ] 5 minutes every drop ;
+ dup [ session get-state ] when ;
GENERIC: init-session* ( responder -- )
@@ -47,9 +34,7 @@ M: filter-responder init-session* responder>> init-session* ;
TUPLE: sessions < filter-responder timeout domain ;
: <sessions> ( responder -- responder' )
- sessions new
- swap >>responder
- 20 minutes >>timeout ;
+ sessions new-server-state-manager ;
: (session-changed) ( session -- )
t >>changed? drop ;
@@ -78,11 +63,8 @@ TUPLE: sessions < filter-responder timeout domain ;
: init-session ( session -- )
session [ sessions get init-session* ] with-variable ;
-: cutoff-time ( -- time )
- sessions get timeout>> from-now ;
-
: touch-session ( session -- )
- cutoff-time >>expires drop ;
+ sessions get touch-state ;
: empty-session ( -- session )
f <session>
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index aa11dd6798..d9b26341e7 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -121,12 +121,12 @@ read-response-test-1' 1array [
] unit-test
! Live-fire exercise
-USING: http.server http.server.static furnace.sessions
+USING: http.server http.server.static furnace.sessions furnace.alloy
furnace.actions furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii
accessors namespaces threads
http.server.responses http.server.redirection
-http.server.dispatchers ;
+http.server.dispatchers db.tuples ;
: add-quit-action
<action>
@@ -138,7 +138,7 @@ http.server.dispatchers ;
[ test-db drop delete-file ] ignore-errors
test-db [
- init-sessions-table
+ init-furnace-tables
] with-db
[ ] [
@@ -269,7 +269,7 @@ SYMBOL: a
! Test flash scope
[ "xyz" ] [
H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
- "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+ "http://localhost:1237/" <post-request> "cookies" get >>cookies B http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 376889b46b..8e3d1a586a 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -90,13 +90,13 @@ LOG: httpd-hit NOTICE
: dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ;
-: prepare-request ( request -- request )
+: prepare-request ( request -- )
[
local-address get
[ secure? "https" "http" ? >>protocol ]
[ port>> '[ , or ] change-port ]
bi
- ] change-url ;
+ ] change-url drop ;
: valid-request? ( request -- ? )
url>> port>> local-address get port>> = ;
diff --git a/extra/persistent-vectors/persistent-vectors-tests.factor b/extra/persistent-vectors/persistent-vectors-tests.factor
index f871c95e16..a4e4ad33fe 100644
--- a/extra/persistent-vectors/persistent-vectors-tests.factor
+++ b/extra/persistent-vectors/persistent-vectors-tests.factor
@@ -24,7 +24,7 @@ random namespaces vectors math math.order ;
[ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
] each
-[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test
+[ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test
[ ] [ "1" get >vector "2" set ] unit-test
[ t ] [
diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor
index 100d4226b7..38bf065e56 100644
--- a/extra/webapps/blogs/blogs.factor
+++ b/extra/webapps/blogs/blogs.factor
@@ -59,8 +59,6 @@ M: post entity-url
: <post> ( id -- post ) \ post new swap >>id ;
-: init-posts-table ( -- ) \ post ensure-table ;
-
TUPLE: comment < entity parent ;
comment "COMMENTS" {
@@ -78,8 +76,6 @@ M: comment entity-url
swap >>id
swap >>parent ;
-: init-comments-table ( -- ) comment ensure-table ;
-
: post ( id -- post )
[ <post> select-tuple ] [ f <comment> select-tuples ] bi
>>comments ;
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
index f56a9b5c6f..55f7ec7ffa 100644
--- a/extra/webapps/factor-website/factor-website.factor
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs io.files io.sockets
io.server
-namespaces db db.sqlite smtp
+namespaces db db.tuples db.sqlite smtp
http.server
http.server.dispatchers
+furnace.alloy
furnace.db
furnace.asides
furnace.flash
@@ -25,24 +26,16 @@ IN: webapps.factor-website
: init-factor-db ( -- )
test-db [
- init-users-table
- init-sessions-table
+ init-furnace-tables
- init-pastes-table
- init-annotations-table
-
- init-blog-table
- init-postings-table
-
- init-todo-table
-
- init-articles-table
- init-revisions-table
-
- init-postings-table
- init-comments-table
-
- init-short-url-table
+ {
+ post comment
+ paste annotation
+ blog posting
+ todo
+ short-url
+ article revision
+ } ensure-tables
] with-db ;
TUPLE: factor-website < dispatcher ;
@@ -63,8 +56,7 @@ TUPLE: factor-website < dispatcher ;
allow-edit-profile
<boilerplate>
{ factor-website "page" } >>template
- <asides> <flash-scopes> <sessions>
- test-db <db-persistence> ;
+ test-db <alloy> ;
: init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
@@ -75,6 +67,6 @@ TUPLE: factor-website < dispatcher ;
<factor-website> main-responder set-global ;
: start-factor-website ( -- )
- test-db start-expiring-sessions
+ test-db start-expiring
test-db start-update-task
8812 httpd ;
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index f6b604c06d..d381adafcd 100644
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -236,7 +236,3 @@ M: annotation entity-url
<delete-annotation-action> "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
-
-: init-pastes-table ( -- ) \ paste ensure-table ;
-
-: init-annotations-table ( -- ) annotation ensure-table ;
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 888d4bd145..90b2411fc1 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -49,10 +49,6 @@ posting "POSTINGS"
{ "date" "DATE" TIMESTAMP +not-null+ }
} define-persistent
-: init-blog-table ( -- ) blog ensure-table ;
-
-: init-postings-table ( -- ) posting ensure-table ;
-
: <blog> ( id -- todo )
blog new
swap >>id ;
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 7cad1eb6ae..0770765754 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -28,8 +28,6 @@ todo "TODO"
{ "description" "DESCRIPTION" { VARCHAR 256 } }
} define-persistent
-: init-todo-table ( -- ) todo ensure-table ;
-
: <todo> ( id -- todo )
todo new
swap >>id
diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor
index d408c645f3..29c4a60bef 100644
--- a/extra/webapps/wee-url/wee-url.factor
+++ b/extra/webapps/wee-url/wee-url.factor
@@ -16,9 +16,6 @@ short-url "SHORT_URLS" {
{ "url" "URL" TEXT +not-null+ }
} define-persistent
-: init-short-url-table ( -- )
- short-url ensure-table ;
-
: letter-bank ( -- seq )
CHAR: a CHAR: z [a,b]
CHAR: A CHAR: Z [a,b]
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 18130f5144..eb3048a26c 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -46,8 +46,6 @@ article "ARTICLES" {
: <article> ( title -- article ) article new swap >>title ;
-: init-articles-table ( -- ) article ensure-table ;
-
TUPLE: revision id title author date content ;
revision "REVISIONS" {
@@ -71,8 +69,6 @@ M: revision feed-entry-url id>> revision-url ;
: <revision> ( id -- revision )
revision new swap >>id ;
-: init-revisions-table ( -- ) revision ensure-table ;
-
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
From a687b5822634f24e434b5e6e0b0181021035fe92 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 22:05:02 -0500
Subject: [PATCH 17/90] Harden farkup against cross-site scripting
---
extra/farkup/farkup.factor | 24 +++++++++++++++---------
1 file changed, 15 insertions(+), 9 deletions(-)
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index 1b51bb5752..d5110de02d 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.styles kernel memoize namespaces peg
-sequences strings html.elements xml.entities xmode.code2html
-splitting io.streams.string peg.parsers
+USING: arrays io io.styles kernel memoize namespaces peg math
+combinators sequences strings html.elements xml.entities
+xmode.code2html splitting io.streams.string peg.parsers
sequences.deep unicode.categories ;
IN: farkup
@@ -67,13 +67,19 @@ MEMO: eq ( -- parser )
</pre>
] with-string-writer ;
+: invalid-url "javascript:alert('Invalid URL in farkup');" ;
+
: check-url ( href -- href' )
- CHAR: : over member? [
- dup { "http://" "https://" "ftp://" } [ head? ] with contains?
- [ drop "/" ] unless
- ] [
- relative-link-prefix get prepend
- ] if ;
+ {
+ { [ 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
+ ] }
+ [ relative-link-prefix get prepend ]
+ } cond ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
From 935d7d432153b5d383371c192678252b33861231 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 22:05:41 -0500
Subject: [PATCH 18/90] Add referrer check responder, harden sessions against
cross-site scripting
---
extra/furnace/actions/actions.factor | 9 +++----
extra/furnace/alloy/alloy.factor | 9 ++++++-
extra/furnace/asides/asides.factor | 2 +-
extra/furnace/furnace.factor | 11 ++++++++
extra/furnace/referrer/referrer.factor | 16 +++++++++++
extra/furnace/sessions/sessions.factor | 27 +++++++++++++++----
extra/http/http-tests.factor | 2 +-
extra/http/server/cgi/cgi.factor | 6 ++---
extra/http/server/server.factor | 2 ++
extra/urls/urls.factor | 2 ++
.../factor-website/factor-website.factor | 2 --
extra/webapps/wiki/wiki.factor | 15 ++++++-----
12 files changed, 76 insertions(+), 27 deletions(-)
create mode 100644 extra/furnace/referrer/referrer.factor
diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor
index a281687096..2b3144fd27 100755
--- a/extra/furnace/actions/actions.factor
+++ b/extra/furnace/actions/actions.factor
@@ -53,7 +53,7 @@ TUPLE: action rest authorize init display validate submit ;
] with-exit-continuation ;
: validation-failed ( -- * )
- request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
+ post-request? [ f ] [ <400> ] if exit-with ;
: (handle-post) ( action -- response )
'[
@@ -70,12 +70,9 @@ TUPLE: action rest authorize init display validate submit ;
: revalidate-url-key "__u" ;
-: check-url ( url -- ? )
- request get url>>
- [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
-
: revalidate-url ( -- url/f )
- revalidate-url-key param dup [ >url dup check-url swap and ] when ;
+ revalidate-url-key param
+ dup [ >url [ same-host? ] keep and ] when ;
: handle-post ( action -- response )
'[
diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor
index 24b47cc4b8..14ffbaba9d 100644
--- a/extra/furnace/alloy/alloy.factor
+++ b/extra/furnace/alloy/alloy.factor
@@ -5,12 +5,19 @@ furnace.cache
furnace.asides
furnace.flash
furnace.sessions
+furnace.referrer
furnace.db
furnace.auth.providers ;
IN: furnace.alloy
: <alloy> ( responder db params -- responder' )
- [ <asides> <flash-scopes> <sessions> ] 2dip <db-persistence> ;
+ '[
+ <asides>
+ <flash-scopes>
+ <sessions>
+ , , <db-persistence>
+ <check-form-submissions>
+ ] call ;
: state-classes { session flash-scope aside } ; inline
diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor
index fc767e050d..15d1c1df0b 100644
--- a/extra/furnace/asides/asides.factor
+++ b/extra/furnace/asides/asides.factor
@@ -51,7 +51,7 @@ ERROR: end-aside-in-get-error ;
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
: end-aside* ( url id -- response )
- request get method>> "POST" = [ end-aside-in-get-error ] unless
+ post-request? [ end-aside-in-get-error ] unless
aside get-state [
dup method>> {
{ "GET" [ url>> <redirect> ] }
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index cdee2821b6..2645146fbf 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -84,6 +84,17 @@ M: object modify-form drop ;
] }
} case ;
+: referrer ( -- referrer )
+ #! Typo is intentional, its in the HTTP spec!
+ "referer" request get header>> at >url ;
+
+: user-agent ( -- user-agent )
+ "user-agent" request get header>> at "" or ;
+
+: same-host? ( url -- ? )
+ request get url>>
+ [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
+
SYMBOL: exit-continuation
: exit-with ( value -- )
diff --git a/extra/furnace/referrer/referrer.factor b/extra/furnace/referrer/referrer.factor
new file mode 100644
index 0000000000..56777676fc
--- /dev/null
+++ b/extra/furnace/referrer/referrer.factor
@@ -0,0 +1,16 @@
+USING: accessors kernel
+http.server http.server.filters http.server.responses
+furnace ;
+IN: furnace.referrer
+
+TUPLE: referrer-check < filter-responder quot ;
+
+C: <referrer-check> referrer-check
+
+M: referrer-check call-responder*
+ referrer over quot>> call
+ [ call-next-method ]
+ [ 2drop 403 "Bad referrer" <trivial-response> ] if ;
+
+: <check-form-submissions> ( responder -- responder' )
+ [ same-host? post-request? not or ] <referrer-check> ;
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index 0c0788a1e6..ab971d24d0 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -2,14 +2,14 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.intervals math.parser namespaces
random accessors quotations hashtables sequences continuations
-fry calendar combinators destructors alarms
+fry calendar combinators destructors alarms io.server
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
furnace furnace.cache ;
IN: furnace.sessions
-TUPLE: session < server-state uid namespace changed? ;
+TUPLE: session < server-state uid namespace user-agent client changed? ;
: <session> ( id -- session )
session new-server-state ;
@@ -18,6 +18,8 @@ session "SESSIONS"
{
{ "uid" "UID" { VARCHAR 255 } }
{ "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+ { "user-agent" "USER_AGENT" TEXT +not-null+ }
+ { "client" "CLIENT" TEXT +not-null+ }
} define-persistent
: get-session ( id -- session )
@@ -31,10 +33,11 @@ M: dispatcher init-session* default>> init-session* ;
M: filter-responder init-session* responder>> init-session* ;
-TUPLE: sessions < filter-responder timeout domain ;
+TUPLE: sessions < server-state-manager domain verify? ;
: <sessions> ( responder -- responder' )
- sessions new-server-state-manager ;
+ sessions new-server-state-manager
+ t >>verify? ;
: (session-changed) ( session -- )
t >>changed? drop ;
@@ -66,9 +69,13 @@ TUPLE: sessions < filter-responder timeout domain ;
: touch-session ( session -- )
sessions get touch-state ;
+: remote-host ( -- string ) remote-address get host>> ;
+
: empty-session ( -- session )
f <session>
H{ } clone >>namespace
+ remote-host >>client
+ user-agent >>user-agent
dup touch-session ;
: begin-session ( -- session )
@@ -107,8 +114,18 @@ M: session-saver dispose
{ "POST" [ post-session-id ] }
} case ;
+: verify-session ( session -- session )
+ sessions get verify?>> [
+ dup [
+ dup
+ [ client>> remote-host = ]
+ [ user-agent>> user-agent = ]
+ bi and [ drop f ] unless
+ ] when
+ ] when ;
+
: request-session ( -- session/f )
- request-session-id get-session ;
+ request-session-id get-session verify-session ;
: <session-cookie> ( id -- cookie )
session-id-key <cookie>
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index d9b26341e7..bc206f08b7 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -269,7 +269,7 @@ SYMBOL: a
! Test flash scope
[ "xyz" ] [
H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
- "http://localhost:1237/" <post-request> "cookies" get >>cookies B http-request nip test-a
+ "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor
index 626cd78e14..3a13b6de39 100755
--- a/extra/http/server/cgi/cgi.factor
+++ b/extra/http/server/cgi/cgi.factor
@@ -5,8 +5,6 @@ combinators arrays io.launcher io http.server.static http.server
http accessors sequences strings math.parser fry urls ;
IN: http.server.cgi
-: post? ( -- ? ) request get method>> "POST" = ;
-
: cgi-variables ( script-path -- assoc )
#! This needs some work.
[
@@ -34,7 +32,7 @@ IN: http.server.cgi
request get "user-agent" header "HTTP_USER_AGENT" set
request get "accept" header "HTTP_ACCEPT" set
- post? [
+ post-request? [
request get post-data>> raw>>
[ "CONTENT_TYPE" set ]
[ length number>string "CONTENT_LENGTH" set ]
@@ -53,7 +51,7 @@ IN: http.server.cgi
"CGI output follows" >>message
swap '[
, output-stream get swap <cgi-process> <process-stream> [
- post? [ request get post-data>> raw>> write flush ] when
+ post-request? [ request get post-data>> raw>> write flush ] when
input-stream get swap (stream-copy)
] with-stream
] >>body ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 8e3d1a586a..4ad44554f5 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -20,6 +20,8 @@ html.elements
html.streams ;
IN: http.server
+: post-request? ( -- ? ) request get method>> "POST" = ;
+
SYMBOL: responder-nesting
SYMBOL: main-responder
diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor
index 7e74fd1115..38511de8e8 100644
--- a/extra/urls/urls.factor
+++ b/extra/urls/urls.factor
@@ -135,6 +135,8 @@ PRIVATE>
GENERIC: >url ( obj -- url )
+M: f >url drop <url> ;
+
M: url >url ;
M: string >url
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
index 55f7ec7ffa..fa598c0948 100644
--- a/extra/webapps/factor-website/factor-website.factor
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -61,9 +61,7 @@ TUPLE: factor-website < dispatcher ;
: init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
"todo@factorcode.org" lost-password-from set-global
-
init-factor-db
-
<factor-website> main-responder set-global ;
: start-factor-website ( -- )
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index eb3048a26c..8dd62c8761 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -39,8 +39,6 @@ TUPLE: article title revision ;
article "ARTICLES" {
{ "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ }
- ! { "AUTHOR" INTEGER +not-null+ } ! uid
- ! { "PROTECTED" BOOLEAN +not-null+ }
{ "revision" "REVISION" INTEGER +not-null+ } ! revision id
} define-persistent
@@ -111,14 +109,17 @@ M: revision feed-entry-url id>> revision-url ;
{ wiki "view" } >>template ;
+: amend-article ( revision article -- )
+ swap id>> >>revision update-tuple ;
+
+: add-article ( revision -- )
+ [ title>> ] [ id>> ] bi article boa insert-tuple ;
+
: add-revision ( revision -- )
[ insert-tuple ]
[
- dup title>> <article> select-tuple [
- swap id>> >>revision update-tuple
- ] [
- [ title>> ] [ id>> ] bi article boa insert-tuple
- ] if*
+ dup title>> <article> select-tuple
+ [ amend-article ] [ add-article ] if*
] bi ;
: <edit-article-action> ( -- action )
From a1ff275a4d0e21f2f309dbc580c84ebbce4c59c3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Jun 2008 23:00:48 -0500
Subject: [PATCH 19/90] Fix test
---
extra/furnace/sessions/sessions-tests.factor | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor
index e203a6fd40..e959cae76a 100755
--- a/extra/furnace/sessions/sessions-tests.factor
+++ b/extra/furnace/sessions/sessions-tests.factor
@@ -1,7 +1,7 @@
IN: furnace.sessions.tests
USING: tools.test http furnace.sessions
furnace.actions http.server http.server.responses
-math namespaces kernel accessors
+math namespaces kernel accessors io.sockets io.server
prettyprint io.streams.string io.files splitting destructors
sequences db db.tuples db.sqlite continuations urls math.parser
furnace ;
@@ -56,6 +56,8 @@ M: foo call-responder*
<request> init-request
session ensure-table
+ "127.0.0.1" 1234 <inet4> remote-address set
+
[ ] [
<foo> <sessions>
sessions set
@@ -63,7 +65,7 @@ M: foo call-responder*
[
[ ] [
- empty-session
+ empty-session
123 >>id session set
] unit-test
From 9b3964c5d68b9201847c74bd13dac468595e6863 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 00:30:51 -0500
Subject: [PATCH 20/90] Add disable images option
---
extra/farkup/farkup.factor | 21 +++++++++++++--------
1 file changed, 13 insertions(+), 8 deletions(-)
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index d5110de02d..321648136a 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -7,6 +7,7 @@ sequences.deep unicode.categories ;
IN: farkup
SYMBOL: relative-link-prefix
+SYMBOL: disable-images?
SYMBOL: link-no-follow?
<PRIVATE
@@ -88,18 +89,22 @@ MEMO: eq ( -- parser )
escape-link
[
"<a" ,
- " href=\"" , >r , r>
+ " href=\"" , >r , r> "\"" ,
link-no-follow? get [ " nofollow=\"true\"" , ] when
- "\">" , , "</a>" ,
+ ">" , , "</a>" ,
] { } make ;
: make-image-link ( href alt -- seq )
- escape-link
- [
- "<img src=\"" , swap , "\"" ,
- dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
- "/>" , ]
- { } make ;
+ disable-images? get [
+ 2drop "<strong>Images are not allowed</strong>"
+ ] [
+ escape-link
+ [
+ "<img src=\"" , swap , "\"" ,
+ dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
+ "/>" ,
+ ] { } make
+ ] if ;
MEMO: image-link ( -- parser )
[
From 51bfaf249b59905147977806b952b40c6644fb94 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 00:31:00 -0500
Subject: [PATCH 21/90] Unit test fix
---
extra/furnace/sessions/sessions-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor
index e959cae76a..a97ba091c0 100755
--- a/extra/furnace/sessions/sessions-tests.factor
+++ b/extra/furnace/sessions/sessions-tests.factor
@@ -65,7 +65,7 @@ M: foo call-responder*
[
[ ] [
- empty-session
+ empty-session
123 >>id session set
] unit-test
From 2c3121cf472cb4412e61145ebb4d2e75d49a45d9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 00:31:10 -0500
Subject: [PATCH 22/90] Add support for some attributes to farkup tag
---
extra/html/components/components.factor | 14 ++++++++++++--
extra/html/templates/chloe/chloe.factor | 2 +-
2 files changed, 13 insertions(+), 3 deletions(-)
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index 42d89811c1..6e1a25f5f5 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -200,10 +200,20 @@ M: code render*
[ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
! Farkup component
-SINGLETON: farkup
+TUPLE: farkup no-follow disable-images ;
+
+: string>boolean ( string -- boolean )
+ {
+ { "true" [ t ] }
+ { "false" [ f ] }
+ } case ;
M: farkup render*
- 2drop string-lines "\n" join convert-farkup write ;
+ [
+ [ 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
+ ] with-scope ;
! Inspector component
SINGLETON: inspector
diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor
index 08d6b873fc..936c06ae7e 100644
--- a/extra/html/templates/chloe/chloe.factor
+++ b/extra/html/templates/chloe/chloe.factor
@@ -98,12 +98,12 @@ CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
CHLOE-SINGLETON: label
CHLOE-SINGLETON: link
-CHLOE-SINGLETON: farkup
CHLOE-SINGLETON: inspector
CHLOE-SINGLETON: comparison
CHLOE-SINGLETON: html
CHLOE-SINGLETON: hidden
+CHLOE-TUPLE: farkup
CHLOE-TUPLE: field
CHLOE-TUPLE: textarea
CHLOE-TUPLE: password
From f0a37253f2d123e5ea313be7403641a50cbba4b9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 00:31:24 -0500
Subject: [PATCH 23/90] Disable comments, make links nofollow in blog posts
---
extra/webapps/blogs/view-post.xml | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml
index 55bdd2e806..d8d4df10b2 100644
--- a/extra/webapps/blogs/view-post.xml
+++ b/extra/webapps/blogs/view-post.xml
@@ -37,7 +37,7 @@
</p>
<p class="posting-body">
- <t:farkup t:name="content" />
+ <t:farkup t:name="content" t:no-follow="true" t:disable-images="true" />
</p>
<t:button t:action="$blogs/delete-comment" t:for="id,parent" class="link-button link">Delete Comment</t:button>
From 2d35ea233ff5860245dc1df0da1f006dcc737cb0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 00:44:23 -0500
Subject: [PATCH 24/90] Fix missing rest parameters
---
extra/webapps/blogs/blogs.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor
index 38bf065e56..d0c651c71f 100644
--- a/extra/webapps/blogs/blogs.factor
+++ b/extra/webapps/blogs/blogs.factor
@@ -116,6 +116,7 @@ M: comment entity-url
: <posts-by-feed-action> ( -- action )
<feed-action>
+ "author" >>rest
[ validate-author ] >>init
[ "Recent Posts by " "author" value append ] >>title
[ list-posts ] >>entries
@@ -123,6 +124,7 @@ M: comment entity-url
: <post-feed-action> ( -- action )
<feed-action>
+ "id" >>rest
[ validate-integer-id "id" value post "post" set-value ] >>init
[ "post" value feed-entry-title ] >>title
[ "post" value entity-url ] >>url
From 23f957850535953071464461b40ad5c7ecfb0b98 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 02:45:04 -0500
Subject: [PATCH 25/90] Remove micro-pessimization
---
extra/io/ports/ports.factor | 6 ++----
1 file changed, 2 insertions(+), 4 deletions(-)
diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor
index b761ecaf5b..f54cd2e9b3 100755
--- a/extra/io/ports/ports.factor
+++ b/extra/io/ports/ports.factor
@@ -98,11 +98,9 @@ TUPLE: output-port < buffered-port ;
: <output-port> ( handle -- output-port )
output-port <buffered-port> ;
-: can-write? ( len buffer -- ? )
- [ buffer-fill + ] keep buffer-capacity <= ;
-
: wait-to-write ( len port -- )
- tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
+ tuck buffer>> buffer-capacity <=
+ [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
dup check-disposed
From faa96f887bbc37492b7a1df3c3ad815c91ac3c71 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 02:45:26 -0500
Subject: [PATCH 26/90] Log rotation
---
extra/http/server/server.factor | 5 ++++-
extra/logging/logging.factor | 8 +++-----
extra/webapps/factor-website/factor-website.factor | 4 ++++
3 files changed, 11 insertions(+), 6 deletions(-)
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 4ad44554f5..095b52171c 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -13,7 +13,7 @@ io.encodings.ascii
io.encodings.binary
io.streams.limited
io.timeouts
-fry logging calendar urls
+fry logging logging.insomniac calendar urls
http
http.server.responses
html.elements
@@ -140,4 +140,7 @@ LOG: httpd-hit NOTICE
: httpd-main ( -- )
8888 httpd ;
+: httpd-insomniac ( -- )
+ "http.server" { httpd-hit } schedule-insomniac ;
+
MAIN: httpd-main
diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor
index f46fcf6c53..5168e7fcd2 100755
--- a/extra/logging/logging.factor
+++ b/extra/logging/logging.factor
@@ -42,11 +42,9 @@ SYMBOL: log-service
<PRIVATE
-PREDICATE: one-string-array < array
- [ length 1 = ] [ [ string? ] all? ] bi and ;
-
: stack>message ( obj -- inputs>message )
- dup one-string-array? [ first ] [
+ dup array? [ dup length 1 = [ first ] when ] when
+ dup string? [
[
string-limit off
1 line-limit set
@@ -54,7 +52,7 @@ PREDICATE: one-string-array < array
0 margin set
unparse
] with-scope
- ] if ;
+ ] unless ;
PRIVATE>
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
index fa598c0948..04fc0487b8 100644
--- a/extra/webapps/factor-website/factor-website.factor
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -3,6 +3,7 @@
USING: accessors kernel sequences assocs io.files io.sockets
io.server
namespaces db db.tuples db.sqlite smtp
+logging.insomniac
http.server
http.server.dispatchers
furnace.alloy
@@ -61,10 +62,13 @@ TUPLE: factor-website < dispatcher ;
: init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
"todo@factorcode.org" lost-password-from set-global
+ "website@factorcode.org" insomniac-sender set-global
+ "slava@factorcode.org" insomniac-recipients set-global
init-factor-db
<factor-website> main-responder set-global ;
: start-factor-website ( -- )
test-db start-expiring
test-db start-update-task
+ httpd-insomniac
8812 httpd ;
From 4e4731ec67fdbdcdce5f557d434e0de634d99a97 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 02:45:34 -0500
Subject: [PATCH 27/90] Fix rollback
---
extra/webapps/wiki/revisions.xml | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml
index 97a051cd96..0e1af75a8f 100644
--- a/extra/webapps/wiki/revisions.xml
+++ b/extra/webapps/wiki/revisions.xml
@@ -16,7 +16,7 @@
<tr>
<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>
+ <td> <t:button t:action="$wiki/rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
</tr>
</t:bind-each>
</table>
From 9516d781542f44754e38c6b411ddac10b02bd1c2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 04:00:40 -0500
Subject: [PATCH 28/90] Fix bootstrap
---
extra/io/ports/ports-docs.factor | 4 ----
1 file changed, 4 deletions(-)
diff --git a/extra/io/ports/ports-docs.factor b/extra/io/ports/ports-docs.factor
index 7420cac115..47485193cf 100755
--- a/extra/io/ports/ports-docs.factor
+++ b/extra/io/ports/ports-docs.factor
@@ -64,7 +64,3 @@ HELP: (wait-to-read)
HELP: wait-to-read
{ $values { "port" input-port } { "eof?" "a boolean" } }
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ;
-
-HELP: can-write?
-{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }
-{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;
From a2fa1369b04c867720ffcd360fa0c3016a225560 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 04:00:57 -0500
Subject: [PATCH 29/90] Furnace fixes
---
extra/furnace/actions/actions.factor | 2 +-
extra/furnace/furnace.factor | 3 ++-
extra/furnace/sessions/sessions.factor | 8 ++++++--
3 files changed, 9 insertions(+), 4 deletions(-)
diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor
index 2b3144fd27..9cc1880cc3 100755
--- a/extra/furnace/actions/actions.factor
+++ b/extra/furnace/actions/actions.factor
@@ -76,7 +76,7 @@ TUPLE: action rest authorize init display validate submit ;
: handle-post ( action -- response )
'[
- form-nesting-key params get at " " split
+ form-nesting-key params get at " " split harvest
[ , (handle-post) ]
[ swap '[ , , nest-values ] ] reduce
call
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 2645146fbf..a51841d4ad 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -109,7 +109,8 @@ SYMBOL: exit-continuation
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
: a-url-path ( tag -- string )
- [ "href" required-attr ] [ "rest" optional-attr value ] bi
+ [ "href" required-attr ]
+ [ "rest" optional-attr dup [ value ] when ] bi
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( tag -- url )
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index ab971d24d0..4be7403e39 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.intervals math.parser namespaces
random accessors quotations hashtables sequences continuations
-fry calendar combinators destructors alarms io.server
+fry calendar combinators combinators.lib destructors alarms io.server
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
@@ -69,7 +69,11 @@ TUPLE: sessions < server-state-manager domain verify? ;
: touch-session ( session -- )
sessions get touch-state ;
-: remote-host ( -- string ) remote-address get host>> ;
+: remote-host ( -- string )
+ {
+ [ request get "x-forwarded-for" header ]
+ [ remote-address get host>> ]
+ } 0|| ;
: empty-session ( -- session )
f <session>
From 198b1a0d56510f8ac75af900c8ec4338223f3b43 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 04:01:07 -0500
Subject: [PATCH 30/90] Clean up quadratic
---
extra/math/quadratic/quadratic.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/math/quadratic/quadratic.factor b/extra/math/quadratic/quadratic.factor
index 2253582623..60929b92cb 100644
--- a/extra/math/quadratic/quadratic.factor
+++ b/extra/math/quadratic/quadratic.factor
@@ -3,13 +3,13 @@
USING: kernel math math.functions ;
IN: math.quadratic
-: monic ( c b a -- c' b' ) tuck / >r / r> ;
+: monic ( c b a -- c' b' ) tuck [ / ] 2bi@ ;
: discriminant ( c b -- b d ) tuck sq 4 / swap - sqrt ;
-: critical ( b d -- -b/2 d ) >r -2 / r> ;
+: critical ( b d -- -b/2 d ) [ -2 / ] dip ;
-: +- ( x y -- x+y x-y ) [ + ] 2keep - ;
+: +- ( x y -- x+y x-y ) [ + ] [ - ] 2bi ;
: quadratic ( c b a -- alpha beta )
#! Solve a quadratic equation ax^2 + bx + c = 0
@@ -17,4 +17,4 @@ IN: math.quadratic
: qeval ( x c b a -- y )
#! Evaluate ax^2 + bx + c
- >r pick * r> roll sq * + + ;
+ [ pick * ] dip roll sq * + + ;
From 149e4345c6d581e2088bc9a8bab2cb32f9d8cf8d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 04:01:16 -0500
Subject: [PATCH 31/90] Add sanity checks
---
extra/html/components/components.factor | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index 6e1a25f5f5..7355cd153d 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -10,9 +10,12 @@ IN: html.components
SYMBOL: values
-: value ( name -- value ) values get at ;
+: check-value-name ( name -- name )
+ dup string? [ "Value name not a string" throw ] unless ;
-: set-value ( value name -- ) values get set-at ;
+: value ( name -- value ) check-value-name values get at ;
+
+: set-value ( value name -- ) check-value-name values get set-at ;
: blank-values ( -- ) H{ } clone values set ;
From 501588ab76622b3ab7882a4d385b0c628706e597 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 04:01:25 -0500
Subject: [PATCH 32/90] add x-forwarded-for logging
---
extra/http/server/server.factor | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 095b52171c..03822ec854 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -78,9 +78,15 @@ main-responder global [ <404> <trivial-responder> or ] change-at
LOG: httpd-hit NOTICE
+LOG: httpd-header NOTICE
+
+: log-header ( headers name -- )
+ tuck header 2array httpd-header ;
+
: log-request ( request -- )
- [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi
- 3array httpd-hit ;
+ [ [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ]
+ [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
+ bi ;
: split-path ( string -- path )
"/" split harvest ;
From 5692d28ce5cdd47aff5cc906c08706bedf2b466b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 04:06:43 -0500
Subject: [PATCH 33/90] Fix compile error
---
extra/editors/vim/vim.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor
index 9ce256868b..8ec94a7fd6 100755
--- a/extra/editors/vim/vim.factor
+++ b/extra/editors/vim/vim.factor
@@ -6,11 +6,11 @@ SYMBOL: vim-path
SYMBOL: vim-detach
SYMBOL: vim-editor
-HOOK: vim-command vim-editor
+HOOK: vim-command vim-editor ( file line -- array )
TUPLE: vim ;
-M: vim vim-command ( file line -- array )
+M: vim vim-command
[
vim-path get , swap , "+" swap number>string append ,
] { } make ;
From b8380711e459fb27cd36d6f5c70c4662d2f79133 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 04:11:30 -0500
Subject: [PATCH 34/90] Clean up editors.vim/gvim a bit
---
extra/editors/gvim/gvim.factor | 6 +++---
extra/editors/vim/vim.factor | 4 ++--
2 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor
index 62150bdf49..240af7d8ef 100755
--- a/extra/editors/gvim/gvim.factor
+++ b/extra/editors/gvim/gvim.factor
@@ -3,14 +3,14 @@ namespaces sequences system combinators
editors.vim editors.gvim.backend vocabs.loader ;
IN: editors.gvim
-TUPLE: gvim ;
+SINGLETON: gvim
M: gvim vim-command ( file line -- string )
- [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
+ [ gvim-path , swap , "+" swap number>string append , ] { } make ;
t vim-detach set-global ! don't block the ui
-T{ gvim } vim-editor set-global
+gvim vim-editor set-global
{
{ [ os unix? ] [ "editors.gvim.unix" ] }
diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor
index 8ec94a7fd6..29c16f7cc3 100755
--- a/extra/editors/vim/vim.factor
+++ b/extra/editors/vim/vim.factor
@@ -8,7 +8,7 @@ SYMBOL: vim-detach
SYMBOL: vim-editor
HOOK: vim-command vim-editor ( file line -- array )
-TUPLE: vim ;
+SINGLETON: vim
M: vim vim-command
[
@@ -23,4 +23,4 @@ M: vim vim-command
"vim" vim-path set-global
[ vim-location ] edit-hook set-global
-T{ vim } vim-editor set-global
+vim vim-editor set-global
From bd7bee867b15c35be5477a4874c27d1806d12af3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 04:18:29 -0500
Subject: [PATCH 35/90] Fix test failure
---
extra/html/components/components-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor
index 2ae120b527..8ec3a58611 100644
--- a/extra/html/components/components-tests.factor
+++ b/extra/html/components/components-tests.factor
@@ -156,7 +156,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
[ "<ul><li>foo</li><li>bar</li></ul>" ] [
- [ "farkup" farkup render ] with-string-writer
+ [ "farkup" T{ farkup } render ] with-string-writer
] unit-test
[ ] [ { 1 2 3 } "object" set-value ] unit-test
From 5b4809e49d36d9ab8129912c874ed0c69525ff2e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Jun 2008 04:21:52 -0500
Subject: [PATCH 36/90] Remove dead code
---
extra/editors/gvim/gvim.factor | 2 --
extra/editors/vim/vim-docs.factor | 4 +---
extra/editors/vim/vim.factor | 6 +-----
3 files changed, 2 insertions(+), 10 deletions(-)
diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor
index 240af7d8ef..041f3db675 100755
--- a/extra/editors/gvim/gvim.factor
+++ b/extra/editors/gvim/gvim.factor
@@ -8,8 +8,6 @@ SINGLETON: gvim
M: gvim vim-command ( file line -- string )
[ gvim-path , swap , "+" swap number>string append , ] { } make ;
-t vim-detach set-global ! don't block the ui
-
gvim vim-editor set-global
{
diff --git a/extra/editors/vim/vim-docs.factor b/extra/editors/vim/vim-docs.factor
index 020117564d..cf42884084 100644
--- a/extra/editors/vim/vim-docs.factor
+++ b/extra/editors/vim/vim-docs.factor
@@ -11,7 +11,5 @@ $nl
"USE: vim"
"\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global"
}
-"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "."
-$nl
-"If you are running the terminal version of Vim, you want it to block Factor until exiting, but for GVim the opposite is desired, so that one can work in Factor and GVim concurrently. The " { $link vim-detach } " global variable can be set to " { $link t } " to detach the Vim process. The default is " { $link f } "." ;
+"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ;
diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor
index 29c16f7cc3..bfbb8f15a5 100755
--- a/extra/editors/vim/vim.factor
+++ b/extra/editors/vim/vim.factor
@@ -3,7 +3,6 @@ namespaces parser prettyprint sequences editors accessors ;
IN: editors.vim
SYMBOL: vim-path
-SYMBOL: vim-detach
SYMBOL: vim-editor
HOOK: vim-command vim-editor ( file line -- array )
@@ -16,10 +15,7 @@ M: vim vim-command
] { } make ;
: vim-location ( file line -- )
- vim-command
- <process> swap >>command
- vim-detach get-global [ t >>detached ] when
- try-process ;
+ vim-command try-process ;
"vim" vim-path set-global
[ vim-location ] edit-hook set-global
From 10477bf7dd3c9b60341ab65da76313797ba0ebae Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 14 Jun 2008 13:09:54 -0500
Subject: [PATCH 37/90] newfx: a few additions
---
extra/newfx/newfx.factor | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index be30dfe370..0504744240 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -189,4 +189,9 @@ METHOD: as-mutate { object object assoc } set-at ;
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
-! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
+! indicate that this is the main objective of the word, as a side effect.
+
+: adjoin ( seq elt -- seq ) over sets:adjoin ;
+: adjoin-on ( elt seq -- seq ) sets:adjoin ;
+: adjoined ( set elt -- set ) swap sets:adjoin ;
+: adjoined-on ( elt set -- ) sets:adjoin ;
\ No newline at end of file
From a36307a11b7f4d4a1cb60cb7d4a33d2910a70916 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 14 Jun 2008 14:44:32 -0500
Subject: [PATCH 38/90] newfx: minor fix
---
extra/newfx/newfx.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index 0504744240..e7d92bba58 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -192,6 +192,6 @@ METHOD: as-mutate { object object assoc } set-at ;
! indicate that this is the main objective of the word, as a side effect.
: adjoin ( seq elt -- seq ) over sets:adjoin ;
-: adjoin-on ( elt seq -- seq ) sets:adjoin ;
-: adjoined ( set elt -- set ) swap sets:adjoin ;
+: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ;
+: adjoined ( set elt -- ) swap sets:adjoin ;
: adjoined-on ( elt set -- ) sets:adjoin ;
\ No newline at end of file
From 094cb776fb8dd994ca8bd60dccd0870cbcabdd4e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 14 Jun 2008 14:45:37 -0500
Subject: [PATCH 39/90] dns.server: add CNAME to rr->rdata-names
---
extra/dns/server/server.factor | 7 ++++---
1 file changed, 4 insertions(+), 3 deletions(-)
diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor
index de36d661aa..7d52ff9e88 100644
--- a/extra/dns/server/server.factor
+++ b/extra/dns/server/server.factor
@@ -50,9 +50,10 @@ IN: dns.server
: rr->rdata-names ( rr -- names/f )
{
- { [ dup type>> NS = ] [ rdata>> {1} ] }
- { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
- { [ t ] [ drop f ] }
+ { [ dup type>> NS = ] [ rdata>> {1} ] }
+ { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
+ { [ dup type>> CNAME = ] [ rdata>> {1} ] }
+ { [ t ] [ drop f ] }
}
cond ;
From b8f1d71d2eb6874ae81a42fdef1855bd8eb6ac75 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 14 Jun 2008 15:48:07 -0500
Subject: [PATCH 40/90] dns.server: do work in separate thread
---
extra/dns/server/server.factor | 19 +++++++++++--------
1 file changed, 11 insertions(+), 8 deletions(-)
diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor
index 7d52ff9e88..b556780805 100644
--- a/extra/dns/server/server.factor
+++ b/extra/dns/server/server.factor
@@ -1,8 +1,8 @@
-USING: kernel combinators sequences sets math
+USING: kernel combinators sequences sets math threads
io.sockets unicode.case accessors
combinators.cleave combinators.lib
- newfx
+ newfx fry
dns dns.util dns.misc ;
IN: dns.server
@@ -204,15 +204,18 @@ DEFER: query->rrs
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: loop ( -- )
- socket receive
- swap
+: (handle-request) ( byte-array addr-spec -- )
+ >r
parse-message
find-answer
message->ba
- swap
- socket send
- loop ;
+ r>
+ socket send ;
+
+: handle-request ( byte-array addr-spec -- )
+ '[ , , (handle-request) ] in-thread ;
+
+: loop ( -- ) socket receive handle-request loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 3e6a6c2195b29c7ce3d3ec84ce14ca346c756984 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 14 Jun 2008 16:05:38 -0500
Subject: [PATCH 41/90] newfx: minor fix
---
extra/newfx/newfx.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index e7d92bba58..37c738cd6a 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -1,11 +1,12 @@
-USING: kernel sequences assocs qualified circular ;
+USING: kernel sequences assocs qualified circular sets ;
USING: math multi-methods ;
QUALIFIED: sequences
QUALIFIED: assocs
QUALIFIED: circular
+QUALIFIED: sets
IN: newfx
From 229ad789071e2485eef9773deeb528d521faa835 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 00:32:48 -0500
Subject: [PATCH 42/90] Slight cleanup
---
core/assocs/assocs.factor | 21 ++++++++++-----------
core/sequences/sequences.factor | 7 ++++---
extra/sequences/lib/lib.factor | 3 ---
3 files changed, 14 insertions(+), 17 deletions(-)
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index c875475278..f56ac810d9 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -20,26 +20,25 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
+: (assoc-each) ( assoc quot -- seq quot' )
+ >r >alist r> [ first2 ] prepose ; inline
+
: assoc-find ( assoc quot -- key value ? )
- >r >alist r> [ first2 ] prepose find swap
- [ first2 t ] [ drop f f f ] if ; inline
+ (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
: key? ( key assoc -- ? ) at* nip ; inline
: assoc-each ( assoc quot -- )
- [ f ] compose assoc-find 3drop ; inline
-
-: (assoc>map) ( quot accum -- quot' )
- [ push ] curry compose ; inline
+ (assoc-each) each ; inline
: assoc>map ( assoc quot exemplar -- seq )
- >r over assoc-size
- <vector> [ (assoc>map) assoc-each ] keep
- r> like ; inline
+ >r accumulator >r assoc-each r> r> like ; inline
+
+: assoc-map-as ( assoc quot exemplar -- newassoc )
+ >r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline
: assoc-map ( assoc quot -- newassoc )
- over >r [ 2array ] compose V{ } assoc>map r> assoc-like ;
- inline
+ over assoc-map-as ; inline
: assoc-push-if ( key value quot accum -- )
>r 2keep r> roll
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index cb33552693..02a7191f0a 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -419,10 +419,11 @@ PRIVATE>
: interleave ( seq between quot -- )
[ (interleave) ] 2curry >r dup length swap r> 2each ; inline
+: accumulator ( quot -- quot' vec )
+ V{ } clone [ [ push ] curry compose ] keep ; inline
+
: unfold ( pred quot tail -- seq )
- V{ } clone [
- swap >r [ push ] curry compose r> while
- ] keep { } like ; inline
+ swap accumulator >r swap while r> { } like ; inline
: follow ( obj quot -- seq )
>r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index ed4c337a92..56488818ab 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -201,9 +201,6 @@ USE: continuations
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
-: accumulator ( quot -- quot vec )
- V{ } clone [ [ push ] curry compose ] keep ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! List the positions of obj in seq
From 292a6fdb0d9af33c193e37881260ab7327527db3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 02:37:28 -0500
Subject: [PATCH 43/90] Fix typo
---
extra/cords/cords.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/cords/cords.factor b/extra/cords/cords.factor
index f5cc89f8d5..a7f4246826 100644
--- a/extra/cords/cords.factor
+++ b/extra/cords/cords.factor
@@ -1,4 +1,4 @@
-! Copysecond (C) 2008 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting math math.order
arrays combinators kernel ;
From 0f2da40977fbf6160d3e2908ddad1b3cf43c43c7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 02:37:37 -0500
Subject: [PATCH 44/90] Better error message
---
extra/io/launcher/launcher.factor | 13 +++++++++----
1 file changed, 9 insertions(+), 4 deletions(-)
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 131cadfaf0..bd90072039 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
-io.streams.duplex io.ports ;
+io.streams.duplex io.ports debugger prettyprint inspector ;
IN: io.launcher
TUPLE: process < identity-tuple
@@ -131,11 +131,16 @@ HOOK: run-process* io-backend ( process -- handle )
run-detached
dup detached>> [ dup wait-for-process drop ] unless ;
-ERROR: process-failed code ;
+ERROR: process-failed process code ;
+
+M: process-failed error.
+ dup "Process exited with error code " write code>> . nl
+ "Launch descriptor:" print nl
+ process>> describe ;
: try-process ( desc -- )
- run-process wait-for-process dup zero?
- [ drop ] [ process-failed ] if ;
+ run-process dup wait-for-process dup zero?
+ [ 2drop ] [ process-failed ] if ;
HOOK: kill-process* io-backend ( handle -- )
From 0ab3f1f436d11f860dad64c71f6f35d9f44d9182 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 02:38:12 -0500
Subject: [PATCH 45/90] New html.forms abstraction fixes some problems; clean
up some code
---
extra/furnace/actions/actions.factor | 67 ++++++-----
extra/furnace/auth/login/login.factor | 8 +-
extra/furnace/flash/flash.factor | 4 +-
extra/furnace/furnace.factor | 5 +-
extra/html/components/components-tests.factor | 21 ++--
extra/html/components/components.factor | 89 +++------------
extra/html/forms/forms-tests.factor | 67 +++++++++++
extra/html/forms/forms.factor | 106 ++++++++++++++++++
extra/html/templates/chloe/chloe-tests.factor | 10 +-
extra/html/templates/chloe/chloe.factor | 3 +-
extra/http/http-tests.factor | 3 +-
extra/validators/validators-tests.factor | 64 -----------
extra/validators/validators.factor | 54 +--------
extra/webapps/blogs/blogs.factor | 12 +-
extra/webapps/pastebin/pastebin.factor | 13 ++-
extra/webapps/planet/planet.factor | 6 +-
extra/webapps/todo/todo.factor | 5 +-
extra/webapps/user-admin/edit-user.xml | 4 +-
extra/webapps/user-admin/user-admin.factor | 38 +++++--
19 files changed, 310 insertions(+), 269 deletions(-)
create mode 100644 extra/html/forms/forms-tests.factor
create mode 100644 extra/html/forms/forms.factor
diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor
index 9cc1880cc3..4b431c83bc 100755
--- a/extra/furnace/actions/actions.factor
+++ b/extra/furnace/actions/actions.factor
@@ -8,6 +8,7 @@ http.server
http.server.responses
furnace
furnace.flash
+html.forms
html.elements
html.components
html.components
@@ -20,10 +21,10 @@ SYMBOL: params
SYMBOL: rest
: render-validation-messages ( -- )
- validation-messages get
+ form get errors>>
dup empty? [ drop ] [
<ul "errors" =class ul>
- [ <li> message>> escape-string write </li> ] each
+ [ <li> escape-string write </li> ] each
</ul>
] if ;
@@ -37,8 +38,21 @@ TUPLE: action rest authorize init display validate submit ;
: <action> ( -- action )
action new-action ;
-: flashed-variables ( -- seq )
- { validation-messages named-validation-messages } ;
+: set-nested-form ( form name -- )
+ dup empty? [
+ drop form set
+ ] [
+ dup length 1 = [
+ first set-value
+ ] [
+ unclip [ set-nested-form ] nest-form
+ ] if
+ ] if ;
+
+: restore-validation-errors ( -- )
+ form fget [
+ nested-forms fget set-nested-form
+ ] when* ;
: handle-get ( action -- response )
'[
@@ -46,25 +60,12 @@ TUPLE: action rest authorize init display validate submit ;
{
[ init>> call ]
[ authorize>> call ]
- [ drop flashed-variables restore-flash ]
+ [ drop restore-validation-errors ]
[ display>> call ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ;
-: validation-failed ( -- * )
- post-request? [ f ] [ <400> ] if exit-with ;
-
-: (handle-post) ( action -- response )
- '[
- , dup submit>> [
- [ validate>> call ]
- [ authorize>> call ]
- [ submit>> call ]
- tri
- ] [ drop <400> ] if
- ] with-exit-continuation ;
-
: param ( name -- value )
params get at ;
@@ -74,24 +75,29 @@ TUPLE: action rest authorize init display validate submit ;
revalidate-url-key param
dup [ >url [ same-host? ] keep and ] when ;
+: validation-failed ( -- * )
+ post-request? revalidate-url and
+ [
+ nested-forms-key param " " split harvest nested-forms set
+ { form nested-forms } <flash-redirect>
+ ] [ <400> ] if*
+ exit-with ;
+
: handle-post ( action -- response )
'[
- form-nesting-key params get at " " split harvest
- [ , (handle-post) ]
- [ swap '[ , , nest-values ] ] reduce
- call
- ] with-exit-continuation
- [
- revalidate-url
- [ flashed-variables <flash-redirect> ] [ <403> ] if*
- ] unless* ;
+ , dup submit>> [
+ [ validate>> call ]
+ [ authorize>> call ]
+ [ submit>> call ]
+ tri
+ ] [ drop <400> ] if
+ ] with-exit-continuation ;
: handle-rest ( path action -- assoc )
rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
: init-action ( path action -- )
- blank-values
- init-validation
+ begin-form
handle-rest
request get request-params assoc-union params set ;
@@ -110,8 +116,7 @@ M: action modify-form
validation-failed? [ validation-failed ] when ;
: validate-params ( validators -- )
- params get swap validate-values from-object
- check-validation ;
+ params get swap validate-values check-validation ;
: validate-integer-id ( -- )
{ { "id" [ v-number ] } } validate-params ;
diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index a1d2bf47c3..80005c452a 100755
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -13,6 +13,7 @@ destructors
checksums
checksums.sha2
validators
+html.forms
html.components
html.elements
urls
@@ -34,13 +35,16 @@ QUALIFIED: smtp
IN: furnace.auth.login
: word>string ( word -- string )
- [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
+ [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
: words>strings ( seq -- seq' )
[ word>string ] map ;
+ERROR: no-such-word name vocab ;
+
: string>word ( string -- word )
- ":" split1 swap lookup ;
+ ":" split1 swap 2dup lookup dup
+ [ 2nip ] [ drop no-such-word ] if ;
: strings>words ( seq -- seq' )
[ string>word ] map ;
diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor
index 43e0d293a5..e06cdac090 100644
--- a/extra/furnace/flash/flash.factor
+++ b/extra/furnace/flash/flash.factor
@@ -25,7 +25,9 @@ TUPLE: flash-scopes < server-state-manager ;
SYMBOL: flash-scope
-: fget ( key -- value ) flash-scope get at ;
+: fget ( key -- value )
+ flash-scope get dup
+ [ namespace>> at ] [ 2drop f ] if ;
: get-flash-scope ( id -- flash-scope )
dup [ flash-scope get-state ] when
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index a51841d4ad..e9d1b29da8 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -10,6 +10,7 @@ xml.entities
xml.writer
html.components
html.elements
+html.forms
html.templates
html.templates.chloe
html.templates.chloe.syntax
@@ -154,11 +155,11 @@ CHLOE: a
input/>
] [ 2drop ] if ;
-: form-nesting-key "__n" ;
+: nested-forms-key "__n" ;
: form-magic ( tag -- )
[ modify-form ] each-responder
- nested-values get " " join f like form-nesting-key hidden-form-field
+ nested-forms get " " join f like nested-forms-key hidden-form-field
"for" optional-attr [ "," split [ hidden render ] each ] when* ;
: form-start-tag ( tag -- )
diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor
index 8ec3a58611..5779371078 100644
--- a/extra/html/components/components-tests.factor
+++ b/extra/html/components/components-tests.factor
@@ -1,9 +1,9 @@
IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
-html.elements html.components namespaces ;
+html.elements html.components html.forms namespaces ;
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
@@ -63,7 +63,7 @@ TUPLE: color red green blue ;
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ "new york" "city1" set-value ] unit-test
@@ -101,7 +101,7 @@ TUPLE: color red green blue ;
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ t "delivery" set-value ] unit-test
@@ -167,12 +167,19 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
=
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [
"factor" [
"concatenative" "model" set-value
- ] nest-values
+ ] nest-form
] unit-test
-[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test
+[
+ H{
+ {
+ "factor"
+ T{ form f V{ } H{ { "model" "concatenative" } } }
+ }
+ }
+] [ values ] unit-test
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index 7355cd153d..b6b7f22b1d 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -1,85 +1,26 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
-classes.tuple words arrays sequences sequences.lib splitting
-mirrors hashtables combinators continuations math strings
-fry locals calendar calendar.format xml.entities validators
-html.elements html.streams xmode.code2html farkup inspector
-lcs.diff2html urls present ;
+classes.tuple words arrays sequences splitting mirrors
+hashtables combinators continuations math strings inspector
+fry locals calendar calendar.format xml.entities
+validators urls present
+xmode.code2html lcs.diff2html farkup
+html.elements html.streams html.forms ;
IN: html.components
-SYMBOL: values
-
-: check-value-name ( name -- name )
- dup string? [ "Value name not a string" throw ] unless ;
-
-: value ( name -- value ) check-value-name values get at ;
-
-: set-value ( value name -- ) check-value-name values get set-at ;
-
-: blank-values ( -- ) H{ } clone values set ;
-
-: prepare-value ( name object -- value name object )
- [ [ value ] keep ] dip ; inline
-
-: from-object ( object -- )
- dup assoc? [ <mirror> ] unless
- values get swap update ;
-
-: deposit-values ( destination names -- )
- [ dup value ] H{ } map>assoc update ;
-
-: deposit-slots ( destination names -- )
- [ <mirror> ] dip deposit-values ;
-
-: with-each-value ( name quot -- )
- [ value ] dip '[
- [
- values [ clone ] change
- 1+ "index" set-value
- "value" set-value
- @
- ] with-scope
- ] each-index ; inline
-
-: with-each-object ( name quot -- )
- [ value ] dip '[
- [
- blank-values
- 1+ "index" set-value
- from-object
- @
- ] with-scope
- ] each-index ; inline
-
-SYMBOL: nested-values
-
-: with-values ( name quot -- )
- '[
- ,
- [ nested-values [ swap prefix ] change ]
- [ value blank-values from-object ]
- bi
- @
- ] with-scope ; inline
-
-: nest-values ( name quot -- )
- swap [
- [
- H{ } clone [ values set call ] keep
- ] with-scope
- ] dip set-value ; inline
-
GENERIC: render* ( value name render -- )
: render ( name renderer -- )
- over named-validation-messages get at [
- [ value>> ] [ message>> ] bi
- [ -rot render* ] dip
- render-error
- ] [
- prepare-value render*
- ] if* ;
+ prepare-value
+ [
+ dup validation-error?
+ [ [ message>> ] [ value>> ] bi ]
+ [ f swap ]
+ if
+ ] 2dip
+ render*
+ [ render-error ] when* ;
<PRIVATE
diff --git a/extra/html/forms/forms-tests.factor b/extra/html/forms/forms-tests.factor
new file mode 100644
index 0000000000..d2dc3ed3a3
--- /dev/null
+++ b/extra/html/forms/forms-tests.factor
@@ -0,0 +1,67 @@
+IN: html.forms.tests
+USING: kernel sequences tools.test assocs html.forms validators accessors
+namespaces ;
+
+: with-validation ( quot -- messages )
+ [
+ begin-form
+ call
+ ] with-scope ; inline
+
+[ 14 ] [
+ [
+ "14" [ v-number 13 v-min-value 100 v-max-value ] validate
+ ] with-validation
+] unit-test
+
+[ t ] [
+ [
+ "140" [ v-number 13 v-min-value 100 v-max-value ] validate
+ [ validation-error? ]
+ [ value>> "140" = ]
+ bi and
+ ] with-validation
+] unit-test
+
+TUPLE: person name age ;
+
+person {
+ { "name" [ ] }
+ { "age" [ v-number 13 v-min-value 100 v-max-value ] }
+} define-validators
+
+[ t t ] [
+ [
+ { { "age" "" } }
+ { { "age" [ v-required ] } }
+ validate-values
+ validation-failed?
+ "age" value
+ [ validation-error? ]
+ [ message>> "required" = ]
+ bi and
+ ] with-validation
+] unit-test
+
+[ H{ { "a" 123 } } f ] [
+ [
+ H{
+ { "a" "123" }
+ { "b" "c" }
+ { "c" "d" }
+ }
+ H{
+ { "a" [ v-integer ] }
+ } validate-values
+ values
+ validation-failed?
+ ] with-validation
+] unit-test
+
+[ t "foo" ] [
+ [
+ "foo" validation-error
+ validation-failed?
+ form get errors>> first
+ ] with-validation
+] unit-test
diff --git a/extra/html/forms/forms.factor b/extra/html/forms/forms.factor
new file mode 100644
index 0000000000..0da3fcb0b3
--- /dev/null
+++ b/extra/html/forms/forms.factor
@@ -0,0 +1,106 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors strings namespaces assocs hashtables
+mirrors math fry sequences sequences.lib words continuations ;
+IN: html.forms
+
+TUPLE: form errors values validation-failed ;
+
+: <form> ( -- form )
+ form new
+ V{ } clone >>errors
+ H{ } clone >>values ;
+
+M: form clone
+ call-next-method
+ [ clone ] change-errors
+ [ clone ] change-values ;
+
+: check-value-name ( name -- name )
+ dup string? [ "Value name not a string" throw ] unless ;
+
+: values ( -- assoc )
+ form get values>> ;
+
+: value ( name -- value )
+ check-value-name values at ;
+
+: set-value ( value name -- )
+ check-value-name values set-at ;
+
+: begin-form ( -- ) <form> form set ;
+
+: prepare-value ( name object -- value name object )
+ [ [ value ] keep ] dip ; inline
+
+: from-object ( object -- )
+ [ values ] [ make-mirror ] bi* update ;
+
+: to-object ( destination names -- )
+ [ make-mirror ] [ values extract-keys ] bi* update ;
+
+: with-each-value ( name quot -- )
+ [ value ] dip '[
+ [
+ form [ clone ] change
+ 1+ "index" set-value
+ "value" set-value
+ @
+ ] with-scope
+ ] each-index ; inline
+
+: with-each-object ( name quot -- )
+ [ value ] dip '[
+ [
+ begin-form
+ 1+ "index" set-value
+ from-object
+ @
+ ] with-scope
+ ] each-index ; inline
+
+SYMBOL: nested-forms
+
+: with-form ( name quot -- )
+ '[
+ ,
+ [ nested-forms [ swap prefix ] change ]
+ [ value form set ]
+ bi
+ @
+ ] with-scope ; inline
+
+: nest-form ( name quot -- )
+ swap [
+ [
+ <form> form set
+ call
+ form get
+ ] with-scope
+ ] dip set-value ; inline
+
+TUPLE: validation-error value message ;
+
+C: <validation-error> validation-error
+
+: validation-error ( message -- )
+ form get
+ t >>validation-failed
+ errors>> push ;
+
+: validation-failed? ( -- ? )
+ form get validation-failed>> ;
+
+: define-validators ( class validators -- )
+ >hashtable "validators" set-word-prop ;
+
+: validate ( value quot -- result )
+ [ <validation-error> ] recover ; inline
+
+: validate-value ( name value quot -- )
+ validate
+ dup validation-error? [ form get t >>validation-failed drop ] when
+ swap set-value ;
+
+: validate-values ( assoc validators -- assoc' )
+ swap '[ dup , at _ validate-value ] assoc-each ;
diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor
index 433aedbc9a..87ba37ed9e 100644
--- a/extra/html/templates/chloe/chloe-tests.factor
+++ b/extra/html/templates/chloe/chloe-tests.factor
@@ -9,13 +9,13 @@ IN: html.templates.chloe.tests
[ f ] [ "" parse-query-attr ] unit-test
[ H{ { "a" "b" } } ] [
- blank-values
+ begin-form
"b" "a" set-value
"a" parse-query-attr
] unit-test
[ H{ { "a" "b" } { "c" "d" } } ] [
- blank-values
+ begin-form
"b" "a" set-value
"d" "c" set-value
"a,c" parse-query-attr
@@ -69,7 +69,7 @@ IN: html.templates.chloe.tests
] run-template
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ "A label" "label" set-value ] unit-test
@@ -157,7 +157,7 @@ TUPLE: person first-name last-name ;
] run-template
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [
H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
@@ -170,7 +170,7 @@ TUPLE: person first-name last-name ;
] unit-test
[ ] [
- blank-values
+ begin-form
{ "a" "b" } "choices" set-value
"true" "b" set-value
] unit-test
diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor
index 936c06ae7e..32fe954178 100644
--- a/extra/html/templates/chloe/chloe.factor
+++ b/extra/html/templates/chloe/chloe.factor
@@ -5,6 +5,7 @@ classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls present
multiline xml xml.data xml.writer xml.utilities
+html.forms
html.elements
html.components
html.templates
@@ -76,7 +77,7 @@ CHLOE: each [ with-each-value ] (bind-tag) ;
CHLOE: bind-each [ with-each-object ] (bind-tag) ;
-CHLOE: bind [ with-values ] (bind-tag) ;
+CHLOE: bind [ with-form ] (bind-tag) ;
: error-message-tag ( tag -- )
children>string render-error ;
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index bc206f08b7..88d42d9796 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -223,7 +223,8 @@ test-db [
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
-USING: html.components html.elements xml xml.utilities validators
+USING: html.components html.elements html.forms
+xml xml.utilities validators
furnace furnace.flash ;
SYMBOL: a
diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor
index 7d4325cbb6..bd24323f20 100644
--- a/extra/validators/validators-tests.factor
+++ b/extra/validators/validators-tests.factor
@@ -2,14 +2,6 @@ IN: validators.tests
USING: kernel sequences tools.test validators accessors
namespaces assocs ;
-: with-validation ( quot -- messages )
- [
- init-validation
- call
- validation-messages get
- named-validation-messages get >alist append
- ] with-scope ; inline
-
[ "" v-one-line ] must-fail
[ "hello world" ] [ "hello world" v-one-line ] unit-test
[ "hello\nworld" v-one-line ] must-fail
@@ -60,59 +52,3 @@ namespaces assocs ;
[ "4561_2612_1234_5467" v-credit-card ] must-fail
[ "4561-2621-1234-5467" v-credit-card ] must-fail
-
-
-[ 14 V{ } ] [
- [
- "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
- ] with-validation
-] unit-test
-
-[ f t ] [
- [
- "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
- ] with-validation first
- [ first "age" = ]
- [ second validation-error? ]
- [ second value>> "140" = ]
- tri and and
-] unit-test
-
-TUPLE: person name age ;
-
-person {
- { "name" [ ] }
- { "age" [ v-number 13 v-min-value 100 v-max-value ] }
-} define-validators
-
-[ t t ] [
- [
- { { "age" "" } } required-values
- validation-failed?
- ] with-validation first
- [ first "age" = ]
- [ second validation-error? ]
- [ second message>> "required" = ]
- tri and and
-] unit-test
-
-[ H{ { "a" 123 } } f V{ } ] [
- [
- H{
- { "a" "123" }
- { "b" "c" }
- { "c" "d" }
- }
- H{
- { "a" [ v-integer ] }
- } validate-values
- validation-failed?
- ] with-validation
-] unit-test
-
-[ t "foo" ] [
- [
- "foo" validation-error
- validation-failed?
- ] with-validation first message>>
-] unit-test
diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor
index aeb2dc2f80..37c0216740 100644
--- a/extra/validators/validators.factor
+++ b/extra/validators/validators.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences sequences.lib math
-namespaces sets math.parser math.ranges assocs regexp fry
-unicode.categories arrays hashtables words combinators mirrors
+namespaces sets math.parser math.ranges assocs regexp
+unicode.categories arrays hashtables words
classes quotations xmode.catalog ;
IN: validators
@@ -107,53 +107,3 @@ IN: validators
] [
"invalid credit card number format" throw
] if ;
-
-SYMBOL: validation-messages
-SYMBOL: named-validation-messages
-
-: init-validation ( -- )
- V{ } clone validation-messages set
- H{ } clone named-validation-messages set ;
-
-: (validation-message) ( obj -- )
- validation-messages get push ;
-
-: (validation-message-for) ( obj name -- )
- named-validation-messages get set-at ;
-
-TUPLE: validation-message message ;
-
-C: <validation-message> validation-message
-
-: validation-message ( string -- )
- <validation-message> (validation-message) ;
-
-: validation-message-for ( string name -- )
- [ <validation-message> ] dip (validation-message-for) ;
-
-TUPLE: validation-error message value ;
-
-C: <validation-error> validation-error
-
-: validation-error ( message -- )
- f <validation-error> (validation-message) ;
-
-: validation-error-for ( message value name -- )
- [ <validation-error> ] dip (validation-message-for) ;
-
-: validation-failed? ( -- ? )
- validation-messages get [ validation-error? ] contains?
- named-validation-messages get [ nip validation-error? ] assoc-contains?
- or ;
-
-: define-validators ( class validators -- )
- >hashtable "validators" set-word-prop ;
-
-: validate ( value name quot -- result )
- '[ drop @ ] [ -rot validation-error-for f ] recover ; inline
-
-: required-values ( assoc -- )
- [ swap [ v-required ] validate drop ] assoc-each ;
-
-: validate-values ( assoc validators -- assoc' )
- swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ;
diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor
index d0c651c71f..760951eec6 100644
--- a/extra/webapps/blogs/blogs.factor
+++ b/extra/webapps/blogs/blogs.factor
@@ -1,8 +1,10 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math.order math.parser
-urls validators html.components db db.types db.tuples calendar
-present http.server.dispatchers
+urls validators db db.types db.tuples calendar present
+html.forms
+html.components
+http.server.dispatchers
furnace
furnace.actions
furnace.auth
@@ -142,7 +144,7 @@ M: comment entity-url
"id" value
"new-comment" [
"parent" set-value
- ] nest-values
+ ] nest-form
] >>init
{ blogs "view-post" } >>template ;
@@ -163,7 +165,7 @@ M: comment entity-url
[
f <post>
- dup { "title" "content" } deposit-slots
+ dup { "title" "content" } to-object
uid >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
@@ -195,7 +197,7 @@ M: comment entity-url
[
"id" value <post>
- dup { "title" "author" "date" "content" } deposit-slots
+ dup { "title" "author" "date" "content" } to-object
[ update-tuple ] [ entity-url <redirect> ] bi
] >>submit
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index d381adafcd..251872d1ac 100644
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -4,6 +4,7 @@ USING: namespaces assocs sorting sequences kernel accessors
hashtables sequences.lib db.types db.tuples db combinators
calendar calendar.format math.parser syndication urls xml.writer
xmode.catalog validators
+html.forms
html.components
html.templates.chloe
http.server
@@ -126,7 +127,7 @@ M: annotation entity-url
"parent" set-value
mode-names "modes" set-value
"factor" "mode" set-value
- ] nest-values
+ ] nest-form
] >>init
{ pastebin "paste" } >>template ;
@@ -149,7 +150,7 @@ M: annotation entity-url
: deposit-entity-slots ( tuple -- )
now >>date
- { "summary" "author" "mode" "contents" } deposit-slots ;
+ { "summary" "author" "mode" "contents" } to-object ;
: <new-paste-action> ( -- action )
<page-action>
@@ -160,11 +161,12 @@ M: annotation entity-url
{ pastebin "new-paste" } >>template
- [ mode-names "modes" set-value ] >>validate
+ [
+ mode-names "modes" set-value
+ validate-entity
+ ] >>validate
[
- validate-entity
-
f <paste>
[ deposit-entity-slots ]
[ insert-tuple ]
@@ -196,6 +198,7 @@ M: annotation entity-url
: <new-annotation-action> ( -- action )
<action>
[
+ mode-names "modes" set-value
{ { "parent" [ v-integer ] } } validate-params
validate-entity
] >>validate
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 90b2411fc1..b472881e73 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -3,9 +3,9 @@
USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db fry locals hashtables
+syndication urls xml.writer validators
+html.forms
html.components
-syndication urls xml.writer
-validators
http.server
http.server.dispatchers
furnace
@@ -130,7 +130,7 @@ posting "POSTINGS"
} validate-params ;
: deposit-blog-slots ( blog -- )
- { "name" "www-url" "feed-url" } deposit-slots ;
+ { "name" "www-url" "feed-url" } to-object ;
: <new-blog-action> ( -- action )
<page-action>
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 0770765754..dba10184f4 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces
db db.types db.tuples validators hashtables urls
+html.forms
html.components
html.templates.chloe
http.server
@@ -62,7 +63,7 @@ todo "TODO"
[
f <todo>
- dup { "summary" "priority" "description" } deposit-slots
+ dup { "summary" "priority" "description" } to-object
[ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;
@@ -82,7 +83,7 @@ todo "TODO"
[
f <todo>
- dup { "id" "summary" "priority" "description" } deposit-slots
+ dup { "id" "summary" "priority" "description" } to-object
[ update-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;
diff --git a/extra/webapps/user-admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml
index 0c55f8ca76..252667462b 100644
--- a/extra/webapps/user-admin/edit-user.xml
+++ b/extra/webapps/user-admin/edit-user.xml
@@ -50,11 +50,11 @@
</table>
<p>
- <button type="submit" class="link-button link">Update</button>
+ <button type="submit" >Update</button>
<t:validation-messages />
</p>
</t:form>
- <t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
+ <t:button t:action="$user-admin/delete" t:for="username">Delete</t:button>
</t:chloe>
diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor
index 19153e1354..5859d616ee 100644
--- a/extra/webapps/user-admin/user-admin.factor
+++ b/extra/webapps/user-admin/user-admin.factor
@@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators words
assocs db.tuples arrays splitting strings validators urls
+html.forms
html.elements
html.components
furnace
@@ -26,10 +27,19 @@ TUPLE: user-admin < dispatcher ;
: init-capabilities ( -- )
capabilities get words>strings "capabilities" set-value ;
-: selected-capabilities ( -- seq )
+: validate-capabilities ( -- )
"capabilities" value
- [ param empty? not ] filter
- [ string>word ] map ;
+ [ [ param empty? not ] keep set-value ] each ;
+
+: selected-capabilities ( -- seq )
+ "capabilities" value [ value ] filter [ string>word ] map ;
+
+: validate-user ( -- )
+ {
+ { "username" [ v-username ] }
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ } validate-params ;
: <new-user-action> ( -- action )
<page-action>
@@ -42,14 +52,13 @@ TUPLE: user-admin < dispatcher ;
[
init-capabilities
+ validate-capabilities
+
+ validate-user
{
- { "username" [ v-username ] }
- { "realname" [ v-one-line ] }
{ "new-password" [ v-password ] }
{ "verify-password" [ v-password ] }
- { "email" [ [ v-email ] v-optional ] }
- { "capabilities" [ ] }
} validate-params
same-password-twice
@@ -74,14 +83,16 @@ TUPLE: user-admin < dispatcher ;
: validate-username ( -- )
{ { "username" [ v-username ] } } validate-params ;
+: select-capabilities ( seq -- )
+ [ t swap word>string set-value ] each ;
+
: <edit-user-action> ( -- action )
<page-action>
[
validate-username
"username" value <user> select-tuple
- [ from-object ]
- [ capabilities>> [ "true" swap word>string set-value ] each ] bi
+ [ from-object ] [ capabilities>> select-capabilities ] bi
init-capabilities
] >>init
@@ -89,14 +100,17 @@ TUPLE: user-admin < dispatcher ;
{ user-admin "edit-user" } >>template
[
+ "username" value <user> select-tuple
+ [ from-object ] [ capabilities>> select-capabilities ] bi
+
init-capabilities
+ validate-capabilities
+
+ validate-user
{
- { "username" [ v-username ] }
- { "realname" [ v-one-line ] }
{ "new-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
- { "email" [ [ v-email ] v-optional ] }
} validate-params
"new-password" "verify-password"
From ac4f180857d4dab42ee4123ee4236c34fb239849 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 03:25:36 -0500
Subject: [PATCH 46/90] Fix load errors
---
extra/webapps/wee-url/wee-url.factor | 2 +-
extra/webapps/wiki/wiki.factor | 3 ++-
2 files changed, 3 insertions(+), 2 deletions(-)
diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor
index 29c4a60bef..2396e98b2a 100644
--- a/extra/webapps/wee-url/wee-url.factor
+++ b/extra/webapps/wee-url/wee-url.factor
@@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: math.ranges sequences random accessors combinators.lib
kernel namespaces fry db.types db.tuples urls validators
-html.components http http.server.dispatchers furnace
+html.components html.forms http http.server.dispatchers furnace
furnace.actions furnace.boilerplate ;
IN: webapps.wee-url
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 8dd62c8761..3183b48da9 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar
namespaces splitting sequences sorting math.order present
-html.components syndication
+syndication
+html.components html.forms
http.server
http.server.dispatchers
furnace
From 10a87fc0afd0c671350f7cbedd9f1dd57a8cdf2f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 03:25:41 -0500
Subject: [PATCH 47/90] Fix compile errors
---
extra/xmode/catalog/catalog.factor | 2 +-
extra/xmode/loader/loader.factor | 8 ++++----
extra/xmode/loader/syntax/syntax.factor | 2 +-
extra/xmode/utilities/utilities.factor | 3 +--
4 files changed, 7 insertions(+), 8 deletions(-)
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 8c6025f726..98276caf83 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -5,7 +5,7 @@ IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
-<TAGS: parse-mode-tag
+<TAGS: parse-mode-tag ( modes tag -- )
TAG: MODE
"NAME" over at >r
diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor
index 5cf3675941..8039db0ac9 100755
--- a/extra/xmode/loader/loader.factor
+++ b/extra/xmode/loader/loader.factor
@@ -7,15 +7,15 @@ IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler
! RULES and its children
-<TAGS: parse-rule-tag
+<TAGS: parse-rule-tag ( rule-set tag -- )
-TAG: PROPS ( rule-set tag -- )
+TAG: PROPS
parse-props-tag swap set-rule-set-props ;
-TAG: IMPORT ( rule-set tag -- )
+TAG: IMPORT
"DELEGATE" swap at swap import-rule-set ;
-TAG: TERMINATE ( rule-set tag -- )
+TAG: TERMINATE
"AT_CHAR" swap at string>number swap set-rule-set-terminate-char ;
RULE: SEQ seq-rule
diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor
index 175c8ed22f..b3adf5cb60 100644
--- a/extra/xmode/loader/syntax/syntax.factor
+++ b/extra/xmode/loader/syntax/syntax.factor
@@ -75,7 +75,7 @@ SYMBOL: ignore-case?
[ parse-literal-matcher swap set-rule-end ] , ;
! SPAN's children
-<TAGS: parse-begin/end-tag
+<TAGS: parse-begin/end-tag ( rule tag -- )
TAG: BEGIN
! XXX
diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor
index 0321974c9e..2e1d0a2872 100644
--- a/extra/xmode/utilities/utilities.factor
+++ b/extra/xmode/utilities/utilities.factor
@@ -48,11 +48,10 @@ SYMBOL: tag-handler-word
: (TAG:) ( name quot -- ) swap tag-handlers get set-at ;
: TAG:
- f set-word
scan parse-definition
(TAG:) ; parsing
: TAGS>
tag-handler-word get
tag-handlers get >alist [ >r dup name-tag r> case ] curry
- (( tag -- )) define-declared ; parsing
+ define ; parsing
From 2b413f1eb7e1453c6fdc9384fe1ade468d77c0e0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 04:56:15 -0500
Subject: [PATCH 48/90] Add request timing
---
extra/http/server/server.factor | 27 ++++++++++++++++++---------
extra/io/server/server.factor | 10 +++++-----
2 files changed, 23 insertions(+), 14 deletions(-)
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 03822ec854..dc66cb1507 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
-combinators tools.vocabs math
+combinators tools.vocabs tools.time math
io
io.server
io.sockets
@@ -26,7 +26,9 @@ SYMBOL: responder-nesting
SYMBOL: main-responder
-SYMBOL: development-mode
+SYMBOL: development?
+
+SYMBOL: benchmark?
! path is a sequence of path component strings
GENERIC: call-responder* ( path responder -- response )
@@ -55,7 +57,7 @@ main-responder global [ <404> <trivial-responder> or ] change-at
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
- swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
+ swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
[ write-response ]
@@ -69,7 +71,7 @@ main-responder global [ <404> <trivial-responder> or ] change-at
]
[
utf8 [
- development-mode get
+ development? get
[ http-error. ] [ drop "Response error" rethrow ] if
] with-encoded-output
] recover
@@ -84,7 +86,7 @@ LOG: httpd-header NOTICE
tuck header 2array httpd-header ;
: log-request ( request -- )
- [ [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ]
+ [ [ method>> ] [ url>> ] bi 2array httpd-hit ]
[ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
bi ;
@@ -121,13 +123,20 @@ LOG: httpd-header NOTICE
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- )
- development-mode get-global
- [ global [ refresh-all ] bind ] when ;
+ development? get-global [ global [ refresh-all ] bind ] when ;
: setup-limits ( -- )
1 minutes timeouts
64 1024 * limit-input ;
+LOG: httpd-benchmark DEBUG
+
+: ?benchmark ( quot -- )
+ benchmark? get [
+ [ benchmark ] [ first ] bi request get url>> rot 3array
+ httpd-benchmark
+ ] [ call ] if ; inline
+
: handle-client ( -- )
[
setup-limits
@@ -135,8 +144,8 @@ LOG: httpd-header NOTICE
ascii encode-output
?refresh-all
read-request
- do-request
- do-response
+ [ do-request ] ?benchmark
+ [ do-response ] ?benchmark
] with-destructors ;
: httpd ( port -- )
diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor
index c855fba6be..e975880a14 100755
--- a/extra/io/server/server.factor
+++ b/extra/io/server/server.factor
@@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files
io.streams.duplex logging continuations destructors kernel math
math.parser namespaces parser sequences strings prettyprint
debugger quotations calendar threads concurrency.combinators
-assocs fry accessors ;
+assocs fry accessors arrays ;
IN: io.server
SYMBOL: servers
@@ -17,13 +17,13 @@ LOG: accepted-connection NOTICE
: with-connection ( client remote local quot -- )
'[
- , [ remote-address set ] [ accepted-connection ] bi
- , local-address set
+ , ,
+ [ [ remote-address set ] [ local-address set ] bi* ]
+ [ 2array accepted-connection ]
+ 2bi
@
] with-stream ; inline
-\ with-connection DEBUG add-error-logging
-
: accept-loop ( server quot -- )
[
[ [ accept ] [ addr>> ] bi ] dip
From 52297bcfeb0df86b332f907b590a0842709d49ae Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 04:56:35 -0500
Subject: [PATCH 49/90] Add some simple markup inheritance
---
extra/furnace/boilerplate/boilerplate.factor | 13 ++++++++++---
extra/webapps/wiki/wiki-common.xml | 19 ++++++++++++++++++-
extra/webapps/wiki/wiki.factor | 9 +++++++--
3 files changed, 35 insertions(+), 6 deletions(-)
diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor
index 7c5b7a0c81..a976199661 100644
--- a/extra/furnace/boilerplate/boilerplate.factor
+++ b/extra/furnace/boilerplate/boilerplate.factor
@@ -1,19 +1,26 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces
-html.templates html.templates.chloe
+html.forms
+html.templates
+html.templates.chloe
locals
http.server
http.server.filters
furnace ;
IN: furnace.boilerplate
-TUPLE: boilerplate < filter-responder template ;
+TUPLE: boilerplate < filter-responder template init ;
-: <boilerplate> ( responder -- boilerplate ) f boilerplate boa ;
+: <boilerplate> ( responder -- boilerplate )
+ boilerplate new
+ swap >>responder
+ [ ] >>init ;
M:: boilerplate call-responder* ( path responder -- )
+ begin-form
path responder call-next-method
+ responder init>> call
dup content-type>> "text/html" = [
clone [| body |
[
diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml
index 4c6d1a5b5c..1d08d3832d 100644
--- a/extra/webapps/wiki/wiki-common.xml
+++ b/extra/webapps/wiki/wiki-common.xml
@@ -28,6 +28,23 @@
<h1><t:write-title /></h1>
- <t:call-next-template />
+ <table width="100%">
+ <tr>
+ <td> <t:call-next-template /> </td>
+ <t:if t:value="sidebar">
+ <td valign="top">
+ <t:bind t:name="sidebar">
+ <h2>
+ <t:a t:href="$wiki/view" t:query="title">
+ <t:label t:name="title" />
+ </t:a>
+ </h2>
+
+ <t:farkup t:name="content" />
+ </t:bind>
+ </td>
+ </t:if>
+ </tr>
+ </table>
</t:chloe>
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 3183b48da9..ebaa60777f 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -78,6 +78,10 @@ M: revision feed-entry-url id>> revision-url ;
<action>
[ "Front Page" view-url <redirect> ] >>display ;
+: latest-revision ( title -- revision/f )
+ <article> select-tuple
+ dup [ revision>> <revision> select-tuple ] when ;
+
: <view-article-action> ( -- action )
<action>
@@ -88,8 +92,8 @@ M: revision feed-entry-url id>> revision-url ;
] >>init
[
- "title" value dup <article> select-tuple [
- revision>> <revision> select-tuple from-object
+ "title" value dup latest-revision [
+ from-object
{ wiki "view" } <chloe-content>
] [
edit-url <redirect>
@@ -297,4 +301,5 @@ M: revision feed-entry-url id>> revision-url ;
<list-changes-feed-action> "changes.atom" add-responder
<delete-action> "delete" add-responder
<boilerplate>
+ [ "sidebar" [ "Sidebar" latest-revision from-object ] nest-form ] >>init
{ wiki "wiki-common" } >>template ;
From 56bb1604f0dd1baba733a6e49def22551022f8a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 18:29:10 -0500
Subject: [PATCH 50/90] Fix load errors
---
extra/html/templates/chloe/chloe-tests.factor | 6 +++---
extra/webapps/counter/counter.factor | 2 +-
2 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor
index 87ba37ed9e..4048836cfe 100644
--- a/extra/html/templates/chloe/chloe-tests.factor
+++ b/extra/html/templates/chloe/chloe-tests.factor
@@ -1,7 +1,7 @@
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
-namespaces xml html.components
-splitting unicode.categories furnace ;
+namespaces xml html.components html.forms
+splitting unicode.categories furnace accessors ;
IN: html.templates.chloe.tests
[ f ] [ f parse-query-attr ] unit-test
@@ -160,7 +160,7 @@ TUPLE: person first-name last-name ;
[ ] [ begin-form ] unit-test
[ ] [
- H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
+ <form> H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } >>values "person" set-value
] unit-test
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor
index da646fb76f..30c5d403de 100644
--- a/extra/webapps/counter/counter.factor
+++ b/extra/webapps/counter/counter.factor
@@ -1,6 +1,6 @@
USING: math kernel accessors http.server http.server.dispatchers
furnace furnace.actions furnace.sessions
-html.components html.templates.chloe
+html.components html.forms html.templates.chloe
fry urls ;
IN: webapps.counter
From dbe095a84d6b3dbd954aff510116df2ac04c352c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 21:57:41 -0500
Subject: [PATCH 51/90] Fix revisions
---
extra/webapps/wiki/wiki.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index ebaa60777f..34bad6db18 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -236,8 +236,8 @@ M: revision feed-entry-url id>> revision-url ;
"old-id" "new-id"
[ value <revision> select-tuple ] bi@
[
- [ [ title>> "title" set-value ] [ "old" set-value ] bi ]
- [ "new" set-value ] bi*
+ [ [ title>> "title" set-value ] [ "old" [ from-object ] nest-form ] bi ]
+ [ "new" [ from-object ] nest-form ] bi*
]
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
From 71d65880e57de7a8e763259c37ef618fccee38cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 22:49:54 -0500
Subject: [PATCH 52/90] SSL session resumption
---
.../unix/sockets/secure/secure-tests.factor | 4 +-
extra/io/unix/sockets/secure/secure.factor | 24 ++-
extra/openssl/libssl/libssl.factor | 154 ++++++++++++------
extra/openssl/openssl.factor | 32 +++-
4 files changed, 154 insertions(+), 60 deletions(-)
diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor
index cbda002354..dca8fbbbc7 100644
--- a/extra/io/unix/sockets/secure/secure-tests.factor
+++ b/extra/io/unix/sockets/secure/secure-tests.factor
@@ -9,7 +9,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
[ ] [ <promise> "port" set ] unit-test
-: with-test-context
+: with-test-context ( quot -- )
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
@@ -28,7 +28,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
] with-test-context
] "SSL server test" spawn drop ;
-: client-test
+: client-test ( -- string )
<secure-config> [
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
] with-secure-context ;
diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor
index 946e0e7be5..a0acbebb3a 100755
--- a/extra/io/unix/sockets/secure/secure.factor
+++ b/extra/io/unix/sockets/secure/secure.factor
@@ -118,13 +118,27 @@ M: secure (get-local-address) addrspec>> (get-local-address) ;
dup dup handle>> SSL_connect check-connect-response dup
[ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
+: resume-session ( ssl-handle ssl-session -- )
+ [ [ handle>> ] dip SSL_set_session ssl-error ]
+ [ drop do-ssl-connect ]
+ 2bi ;
+
+: begin-session ( ssl-handle addrspec -- )
+ [ drop do-ssl-connect ]
+ [ [ handle>> SSL_get1_session ] dip save-session ]
+ 2bi ;
+
+: secure-connection ( ssl-handle addrspec -- )
+ dup get-session [ resume-session ] [ begin-session ] ?if ;
+
M: secure establish-connection ( client-out remote -- )
- [ addrspec>> establish-connection ]
+ addrspec>>
+ [ establish-connection ]
[
- drop handle>>
- [ [ do-ssl-connect ] with-timeout ]
- [ t >>connected drop ]
- bi
+ [ handle>> ] dip
+ [ [ secure-connection ] curry with-timeout ]
+ [ drop t >>connected drop ]
+ 2bi
] 2bi ;
M: secure (server) addrspec>> (server) ;
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index 3218d67b5c..dced2e5c0c 100755
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -1,12 +1,8 @@
! Copyright (C) 2007 Elie CHAFTARI
+! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
-!
-! export LD_LIBRARY_PATH=/opt/local/lib
-
USING: alien alien.syntax combinators kernel system namespaces
-assocs parser sequences words quotations ;
+assocs parser sequences words quotations math.bitfields ;
IN: openssl.libssl
@@ -24,11 +20,47 @@ IN: openssl.libssl
: SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1 ; inline
: SSL_FILETYPE_PEM X509_FILETYPE_PEM ; inline
-: SSL_CTRL_NEED_TMP_RSA 1 ; inline
-: SSL_CTRL_SET_TMP_RSA 2 ; inline
-: SSL_CTRL_SET_TMP_DH 3 ; inline
-: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
-: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
+: SSL_CTRL_NEED_TMP_RSA 1 ; inline
+: SSL_CTRL_SET_TMP_RSA 2 ; inline
+: SSL_CTRL_SET_TMP_DH 3 ; inline
+: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
+: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
+
+: SSL_CTRL_GET_SESSION_REUSED 6 ; inline
+: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7 ; inline
+: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8 ; inline
+: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9 ; inline
+: SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 10 ; inline
+: SSL_CTRL_GET_FLAGS 11 ; inline
+: SSL_CTRL_EXTRA_CHAIN_CERT 12 ; inline
+
+: SSL_CTRL_SET_MSG_CALLBACK 13 ; inline
+: SSL_CTRL_SET_MSG_CALLBACK_ARG 14 ; inline
+
+: SSL_CTRL_SESS_NUMBER 20 ; inline
+: SSL_CTRL_SESS_CONNECT 21 ; inline
+: SSL_CTRL_SESS_CONNECT_GOOD 22 ; inline
+: SSL_CTRL_SESS_CONNECT_RENEGOTIATE 23 ; inline
+: SSL_CTRL_SESS_ACCEPT 24 ; inline
+: SSL_CTRL_SESS_ACCEPT_GOOD 25 ; inline
+: SSL_CTRL_SESS_ACCEPT_RENEGOTIATE 26 ; inline
+: SSL_CTRL_SESS_HIT 27 ; inline
+: SSL_CTRL_SESS_CB_HIT 28 ; inline
+: SSL_CTRL_SESS_MISSES 29 ; inline
+: SSL_CTRL_SESS_TIMEOUTS 30 ; inline
+: SSL_CTRL_SESS_CACHE_FULL 31 ; inline
+: SSL_CTRL_OPTIONS 32 ; inline
+: SSL_CTRL_MODE 33 ; inline
+
+: SSL_CTRL_GET_READ_AHEAD 40 ; inline
+: SSL_CTRL_SET_READ_AHEAD 41 ; inline
+: SSL_CTRL_SET_SESS_CACHE_SIZE 42 ; inline
+: SSL_CTRL_GET_SESS_CACHE_SIZE 43 ; inline
+: SSL_CTRL_SET_SESS_CACHE_MODE 44 ; inline
+: SSL_CTRL_GET_SESS_CACHE_MODE 45 ; inline
+
+: SSL_CTRL_GET_MAX_CERT_LIST 50 ; inline
+: SSL_CTRL_SET_MAX_CERT_LIST 51 ; inline
: SSL_ERROR_NONE 0 ; inline
: SSL_ERROR_SSL 1 ; inline
@@ -55,8 +87,9 @@ IN: openssl.libssl
} ;
TYPEDEF: void* ssl-method
-TYPEDEF: void* ssl-ctx
-TYPEDEF: void* ssl-pointer
+TYPEDEF: void* SSL_CTX*
+TYPEDEF: void* SSL_SESSION*
+TYPEDEF: void* SSL*
LIBRARY: libssl
@@ -64,7 +97,7 @@ LIBRARY: libssl
! ssl.h
! ===============================================
-FUNCTION: char* SSL_get_version ( ssl-pointer ssl ) ;
+FUNCTION: char* SSL_get_version ( SSL* ssl ) ;
! Maps OpenSSL errors to strings
FUNCTION: void SSL_load_error_strings ( ) ;
@@ -94,42 +127,50 @@ FUNCTION: ssl-method TLSv1_server_method ( ) ;
FUNCTION: ssl-method TLSv1_method ( ) ;
! Creates the context
-FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ;
+FUNCTION: SSL_CTX* SSL_CTX_new ( ssl-method method ) ;
! Load the certificates and private keys into the SSL_CTX
-FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx,
+FUNCTION: int SSL_CTX_use_certificate_chain_file ( SSL_CTX* ctx,
char* file ) ; ! PEM type
-FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ;
+FUNCTION: SSL* SSL_new ( SSL_CTX* ctx ) ;
-FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ;
+FUNCTION: int SSL_set_fd ( SSL* ssl, int fd ) ;
-FUNCTION: void SSL_set_bio ( ssl-pointer ssl, void* rbio, void* wbio ) ;
+FUNCTION: void SSL_set_bio ( SSL* ssl, void* rbio, void* wbio ) ;
-FUNCTION: int SSL_get_error ( ssl-pointer ssl, int ret ) ;
+FUNCTION: int SSL_set_session ( SSL* to, SSL_SESSION* session ) ;
-FUNCTION: void SSL_set_connect_state ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_get_error ( SSL* ssl, int ret ) ;
-FUNCTION: void SSL_set_accept_state ( ssl-pointer ssl ) ;
+FUNCTION: void SSL_set_connect_state ( SSL* ssl ) ;
-FUNCTION: int SSL_connect ( ssl-pointer ssl ) ;
+FUNCTION: void SSL_set_accept_state ( SSL* ssl ) ;
-FUNCTION: int SSL_accept ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_connect ( SSL* ssl ) ;
-FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ;
+FUNCTION: int SSL_accept ( SSL* ssl ) ;
-FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
+FUNCTION: int SSL_write ( SSL* ssl, void* buf, int num ) ;
-FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_read ( SSL* ssl, void* buf, int num ) ;
+
+FUNCTION: int SSL_shutdown ( SSL* ssl ) ;
: SSL_SENT_SHUTDOWN 1 ;
: SSL_RECEIVED_SHUTDOWN 2 ;
-FUNCTION: int SSL_get_shutdown ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_get_shutdown ( SSL* ssl ) ;
-FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_CTX_set_session_id_context ( SSL_CTX* ctx, char* sid_ctx, uint len ) ;
-FUNCTION: int SSL_want ( ssl-pointer ssl ) ;
+FUNCTION: SSL_SESSION* SSL_get1_session ( SSL* ssl ) ;
+
+FUNCTION: void SSL_free ( SSL* ssl ) ;
+
+FUNCTION: void SSL_SESSION_free ( SSL_SESSION* ses ) ;
+
+FUNCTION: int SSL_want ( SSL* ssl ) ;
: SSL_NOTHING 1 ; inline
: SSL_WRITING 2 ; inline
@@ -140,55 +181,55 @@ FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ;
FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ;
-FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ;
+FUNCTION: void SSL_CTX_free ( SSL_CTX* ctx ) ;
FUNCTION: void RAND_seed ( void* buf, int num ) ;
-FUNCTION: int SSL_set_cipher_list ( ssl-pointer ssl, char* str ) ;
+FUNCTION: int SSL_set_cipher_list ( SSL* ssl, char* str ) ;
-FUNCTION: int SSL_use_RSAPrivateKey_file ( ssl-pointer ssl, char* str ) ;
+FUNCTION: int SSL_use_RSAPrivateKey_file ( SSL* ssl, char* str ) ;
-FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( ssl-ctx ctx, int type ) ;
+FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( SSL_CTX* ctx, int type ) ;
-FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl,
+FUNCTION: int SSL_use_certificate_file ( SSL* ssl,
char* str, int type ) ;
-FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile,
+FUNCTION: int SSL_CTX_load_verify_locations ( SSL_CTX* ctx, char* CAfile,
char* CApath ) ;
-FUNCTION: int SSL_CTX_set_default_verify_paths ( ssl-ctx ctx ) ;
+FUNCTION: int SSL_CTX_set_default_verify_paths ( SSL_CTX* ctx ) ;
: SSL_VERIFY_NONE 0 ; inline
: SSL_VERIFY_PEER 1 ; inline
: SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline
: SSL_VERIFY_CLIENT_ONCE 4 ; inline
-FUNCTION: void SSL_CTX_set_verify ( ssl-ctx ctx, int mode, void* callback ) ;
+FUNCTION: void SSL_CTX_set_verify ( SSL_CTX* ctx, int mode, void* callback ) ;
-FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ;
+FUNCTION: void SSL_CTX_set_client_CA_list ( SSL_CTX* ctx, SSL* list ) ;
-FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ;
+FUNCTION: SSL* SSL_load_client_CA_file ( char* file ) ;
! Used to manipulate settings of the SSL_CTX and SSL objects.
! This function should never be called directly
-FUNCTION: long SSL_CTX_ctrl ( ssl-ctx ctx, int cmd, long larg, void* parg ) ;
+FUNCTION: long SSL_CTX_ctrl ( SSL_CTX* ctx, int cmd, long larg, void* parg ) ;
-FUNCTION: void SSL_CTX_set_default_passwd_cb ( ssl-ctx ctx, void* cb ) ;
+FUNCTION: void SSL_CTX_set_default_passwd_cb ( SSL_CTX* ctx, void* cb ) ;
-FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( ssl-ctx ctx,
+FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( SSL_CTX* ctx,
void* u ) ;
-FUNCTION: int SSL_CTX_use_PrivateKey_file ( ssl-ctx ctx, char* file,
+FUNCTION: int SSL_CTX_use_PrivateKey_file ( SSL_CTX* ctx, char* file,
int type ) ;
-! Sets the maximum depth for the allowed ctx certificate chain verification
-FUNCTION: void SSL_CTX_set_verify_depth ( ssl-ctx ctx, int depth ) ;
+! Sets the maximum depth for the allowed ctx certificate chain verification
+FUNCTION: void SSL_CTX_set_verify_depth ( SSL_CTX* ctx, int depth ) ;
! Sets DH parameters to be used to be dh.
! The key is inherited by all ssl objects created from ctx
-FUNCTION: void SSL_CTX_set_tmp_dh_callback ( ssl-ctx ctx, void* dh ) ;
+FUNCTION: void SSL_CTX_set_tmp_dh_callback ( SSL_CTX* ctx, void* dh ) ;
-FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
+FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ;
FUNCTION: void* BIO_f_ssl ( ) ;
@@ -198,6 +239,23 @@ FUNCTION: void* BIO_f_ssl ( ) ;
: SSL_CTX_set_tmp_dh ( ctx dh -- n )
>r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
+: SSL_CTX_set_session_cache_mode ( ctx mode -- n )
+ >r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ;
+
+: SSL_SESS_CACHE_OFF HEX: 0000 ; inline
+: SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline
+: SSL_SESS_CACHE_SERVER HEX: 0002 ; inline
+
+: SSL_SESS_CACHE_BOTH ( -- n )
+ { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
+
+: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080 ; inline
+: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100 ; inline
+: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 ; inline
+
+: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
+ { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
+
! ===============================================
! x509.h
! ===============================================
diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor
index b2dbda7d2e..6d750bd8e0 100755
--- a/extra/openssl/openssl.factor
+++ b/extra/openssl/openssl.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc
-continuations destructors debugger inspector splitting
-locals unicode.case
+continuations destructors debugger inspector splitting assocs
+random math.parser locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
io.timeouts ;
@@ -48,7 +48,13 @@ SYMBOL: ssl-initialized?
[ f ssl-initialized? set-global ] "openssl" add-init-hook
-TUPLE: openssl-context < secure-context aliens ;
+TUPLE: openssl-context < secure-context aliens sessions ;
+
+: set-session-cache ( ctx -- )
+ handle>>
+ [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
+ [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
+ bi ;
: load-certificate-chain ( ctx -- )
dup config>> key-file>> [
@@ -133,12 +139,20 @@ M: rsa dispose* handle>> RSA_free ;
] bi
SSL_CTX_set_tmp_rsa ssl-error ;
+: <openssl-context> ( config ctx -- context )
+ openssl-context new
+ swap >>handle
+ swap >>config
+ V{ } clone >>aliens
+ H{ } clone >>sessions ;
+
M: openssl <secure-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
- dup ssl-error f V{ } clone openssl-context boa |dispose
+ dup ssl-error <openssl-context> |dispose
{
+ [ set-session-cache ]
[ load-certificate-chain ]
[ set-default-password ]
[ use-private-key-file ]
@@ -152,8 +166,9 @@ M: openssl <secure-context> ( config -- context )
M: openssl-context dispose*
[ aliens>> [ free ] each ]
+ [ sessions>> values [ SSL_SESSION_free ] each ]
[ handle>> SSL_CTX_free ]
- bi ;
+ tri ;
TUPLE: ssl-handle file handle connected disposed ;
@@ -204,4 +219,11 @@ M: openssl check-certificate ( host ssl -- )
2bi
] [ 2drop ] if ;
+: get-session ( addrspec -- session/f )
+ current-secure-context sessions>> at
+ dup expired? [ drop f ] when ;
+
+: save-session ( session addrspec -- )
+ current-secure-context sessions>> set-at ;
+
openssl secure-socket-backend set-global
From 00e97257299fe80e1d8f82a3dc9707c44195dfad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Jun 2008 23:04:17 -0500
Subject: [PATCH 53/90] Fix load error
---
extra/tangle/sandbox/sandbox.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/tangle/sandbox/sandbox.factor b/extra/tangle/sandbox/sandbox.factor
index b6e110ada5..b44acb7617 100644
--- a/extra/tangle/sandbox/sandbox.factor
+++ b/extra/tangle/sandbox/sandbox.factor
@@ -12,7 +12,7 @@ IN: tangle.sandbox
] with-tangle ;
: new-sandbox ( -- )
- development-mode on
+ development? on
delete-db sandbox-db f <tangle>
[ make-sandbox ] [ <tangle-dispatcher> ] bi
main-responder set ;
From a943a237d956b8c1cb051224ad555484384ab4c3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Jun 2008 01:35:06 -0500
Subject: [PATCH 54/90] Fix information leakage
---
extra/http/http-tests.factor | 4 ++++
extra/http/http.factor | 14 ++++++++++++--
extra/http/server/server.factor | 25 +++++++++----------------
3 files changed, 25 insertions(+), 18 deletions(-)
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 88d42d9796..d092e5008f 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -276,3 +276,7 @@ SYMBOL: a
[ 4 ] [ a get-global ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
+
+! Test cloning
+[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
+[ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 521c18c703..25bf20429d 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -6,7 +6,8 @@ assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
-io io.encodings.iana io.encodings.binary io.encodings.8-bit
+io io.encodings io.encodings.iana io.encodings.binary
+io.encodings.8-bit
unicode.case unicode.categories qualified
@@ -298,6 +299,11 @@ body ;
latin1 >>content-charset
V{ } clone >>cookies ;
+M: response clone
+ call-next-method
+ [ clone ] change-header
+ [ clone ] change-cookies ;
+
: read-response-version ( response -- response )
" \t" read-until
[ "Bad response: version" throw ] unless
@@ -363,7 +369,11 @@ M: response write-response ( respose -- )
M: response write-full-response ( request response -- )
dup write-response
- swap method>> "HEAD" = [ write-response-body ] unless ;
+ swap method>> "HEAD" = [
+ [ content-charset>> encode-output ]
+ [ write-response-body ]
+ bi
+ ] unless ;
: get-cookie ( request/response name -- cookie/f )
[ cookies>> ] dip '[ , _ name>> = ] find nip ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index dc66cb1507..f709939e21 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -60,23 +60,16 @@ main-responder global [ <404> <trivial-responder> or ] change-at
swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
- [ write-response ]
+ [ request get swap write-full-response ]
[
- request get method>> "HEAD" = [ drop ] [
- '[
- ,
- [ content-charset>> encode-output ]
- [ write-response-body ]
- bi
- ]
- [
- utf8 [
- development? get
- [ http-error. ] [ drop "Response error" rethrow ] if
- ] with-encoded-output
- ] recover
- ] if
- ] bi ;
+ [ \ do-response log-error ]
+ [
+ utf8 [
+ development? get
+ [ http-error. ] [ drop "Response error" write ] if
+ ] with-encoded-output
+ ] bi
+ ] recover ;
LOG: httpd-hit NOTICE
From 39d8bec7ef41228902ec00e829aa0505ff269528 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Jun 2008 03:34:17 -0500
Subject: [PATCH 55/90] Refactoring furnace.auth
---
extra/furnace/auth/auth.factor | 100 ++++-
extra/furnace/auth/basic/basic.factor | 44 +-
.../furnace/auth/{login => }/boilerplate.xml | 0
.../edit-profile/edit-profile-tests.factor | 4 +
.../features/edit-profile/edit-profile.factor | 67 ++++
.../edit-profile}/edit-profile.xml | 0
.../recover-password}/recover-1.xml | 0
.../recover-password}/recover-2.xml | 0
.../recover-password}/recover-3.xml | 0
.../recover-password}/recover-4.xml | 0
.../recover-password-tests.factor | 4 +
.../recover-password/recover-password.factor | 123 ++++++
.../registration}/register.xml | 0
.../registration/registration-tests.factor | 4 +
.../features/registration/registration.factor | 43 ++
extra/furnace/auth/login/login-tests.factor | 4 +-
extra/furnace/auth/login/login.factor | 379 ++----------------
.../furnace/auth/providers/db/db-tests.factor | 5 +-
extra/furnace/db/db.factor | 3 +-
extra/furnace/sessions/sessions.factor | 9 -
extra/furnace/utilities/utilities.factor | 19 +
extra/http/client/client-tests.factor | 4 +-
extra/http/http-tests.factor | 6 +-
extra/http/http.factor | 3 +-
extra/webapps/blogs/blogs.factor | 14 +-
.../factor-website/factor-website.factor | 11 +-
extra/webapps/todo/todo.factor | 3 +-
extra/webapps/user-admin/user-admin.factor | 8 +-
28 files changed, 426 insertions(+), 431 deletions(-)
rename extra/furnace/auth/{login => }/boilerplate.xml (100%)
create mode 100644 extra/furnace/auth/features/edit-profile/edit-profile-tests.factor
create mode 100644 extra/furnace/auth/features/edit-profile/edit-profile.factor
rename extra/furnace/auth/{login => features/edit-profile}/edit-profile.xml (100%)
rename extra/furnace/auth/{login => features/recover-password}/recover-1.xml (100%)
rename extra/furnace/auth/{login => features/recover-password}/recover-2.xml (100%)
rename extra/furnace/auth/{login => features/recover-password}/recover-3.xml (100%)
rename extra/furnace/auth/{login => features/recover-password}/recover-4.xml (100%)
create mode 100644 extra/furnace/auth/features/recover-password/recover-password-tests.factor
create mode 100644 extra/furnace/auth/features/recover-password/recover-password.factor
rename extra/furnace/auth/{login => features/registration}/register.xml (100%)
create mode 100644 extra/furnace/auth/features/registration/registration-tests.factor
create mode 100644 extra/furnace/auth/features/registration/registration.factor
create mode 100644 extra/furnace/utilities/utilities.factor
diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor
index f78cea3835..d10ba48ce5 100755
--- a/extra/furnace/auth/auth.factor
+++ b/extra/furnace/auth/auth.factor
@@ -1,11 +1,18 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
+destructors combinators
+io.encodings.utf8 io.encodings.string io.binary random
+checksums checksums.sha2
+html.forms
http.server
http.server.filters
http.server.dispatchers
-furnace.sessions
-furnace.auth.providers ;
+furnace
+furnace.actions
+furnace.boilerplate
+furnace.auth.providers
+furnace.auth.providers.db ;
IN: furnace.auth
SYMBOL: logged-in-user
@@ -20,6 +27,9 @@ M: dispatcher init-user-profile
M: filter-responder init-user-profile
responder>> init-user-profile ;
+: have-capability? ( capability -- ? )
+ logged-in-user get capabilities>> member? ;
+
: profile ( -- assoc ) logged-in-user get profile>> ;
: user-changed ( -- )
@@ -41,3 +51,89 @@ SYMBOL: capabilities
V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get adjoin ;
+
+TUPLE: realm < dispatcher name users checksum ;
+
+GENERIC: login-required* ( realm -- response )
+
+GENERIC: logged-in-username ( realm -- username )
+
+: login-required ( -- * ) realm get login-required* exit-with ;
+
+: new-realm ( responder name class -- realm )
+ new-dispatcher
+ swap >>name
+ swap >>default
+ users-in-db >>users
+ sha-256 >>checksum ; inline
+
+: users ( -- provider )
+ realm get users>> ;
+
+TUPLE: user-saver user ;
+
+C: <user-saver> user-saver
+
+M: user-saver dispose
+ user>> dup changed?>> [ users update-user ] [ drop ] if ;
+
+: save-user-after ( user -- )
+ <user-saver> &dispose drop ;
+
+: init-user ( realm -- )
+ logged-in-username [
+ users get-user
+ [ logged-in-user set ] [ save-user-after ] bi
+ ] when* ;
+
+M: realm call-responder* ( path responder -- response )
+ dup realm set
+ dup init-user
+ call-next-method ;
+
+: encode-password ( string salt -- bytes )
+ [ utf8 encode ] [ 4 >be ] bi* append
+ realm get checksum>> checksum-bytes ;
+
+: >>encoded-password ( user string -- user )
+ 32 random-bits [ encode-password ] keep
+ [ >>password ] [ >>salt ] bi* ; inline
+
+: valid-login? ( password user -- ? )
+ [ salt>> encode-password ] [ password>> ] bi = ;
+
+: check-login ( password username -- user/f )
+ users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
+
+TUPLE: protected < filter-responder description capabilities ;
+
+: <protected> ( responder -- protected )
+ protected new
+ swap >>responder ;
+
+: check-capabilities ( responder user/f -- ? )
+ {
+ { [ dup not ] [ 2drop f ] }
+ { [ dup deleted>> ] [ 2drop f ] }
+ [ [ capabilities>> ] bi@ subset? ]
+ } cond ;
+
+M: protected call-responder* ( path responder -- response )
+ dup protected set
+ dup logged-in-user get check-capabilities
+ [ call-next-method ] [ 2drop realm get login-required* ] if ;
+
+: <auth-boilerplate> ( responder -- responder' )
+ <boilerplate> { realm "boilerplate" } >>template ;
+
+: password-mismatch ( -- * )
+ "passwords do not match" validation-error
+ validation-failed ;
+
+: same-password-twice ( -- )
+ "new-password" value "verify-password" value =
+ [ password-mismatch ] unless ;
+
+: user-exists ( -- * )
+ "username taken" validation-error
+ validation-failed ;
diff --git a/extra/furnace/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor
index c8d542c219..ae9cbb82c1 100755
--- a/extra/furnace/auth/basic/basic.factor
+++ b/extra/furnace/auth/basic/basic.factor
@@ -1,41 +1,27 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors quotations assocs kernel splitting
-base64 html.elements io combinators sequences
-http http.server.filters http.server.responses http.server
-furnace.auth.providers furnace.auth.login ;
+USING: accessors kernel splitting base64 namespaces
+http http.server.responses furnace.auth ;
IN: furnace.auth.basic
-TUPLE: basic-auth < filter-responder realm provider ;
+TUPLE: basic-auth-realm < realm ;
-C: <basic-auth> basic-auth
+C: <basic-auth-realm> basic-auth-realm
-: authorization-ok? ( provider header -- ? )
- #! Given the realm and the 'Authorization' header,
- #! authenticate the user.
+: parse-basic-auth ( header -- username/f password/f )
dup [
" " split1 swap "Basic" = [
- base64> ":" split1 spin check-login
- ] [
- 2drop f
- ] if
- ] [
- 2drop f
- ] if ;
+ base64> ":" split1
+ ] [ drop f f ] if
+ ] [ drop f f ] if ;
: <401> ( realm -- response )
- 401 "Unauthorized" <trivial-response>
- "Basic realm=\"" rot "\"" 3append
- "WWW-Authenticate" set-header
- [
- <html> <body>
- "Username or Password is invalid" write
- </body> </html>
- ] >>body ;
+ 401 "Invalid username or password" <trivial-response>
+ [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
-: logged-in? ( request responder -- ? )
- provider>> swap "authorization" header authorization-ok? ;
+M: basic-auth-realm login-required* ( realm -- response )
+ name>> <401> ;
-M: basic-auth call-responder* ( request path responder -- response )
- pick over logged-in?
- [ call-next-method ] [ 2nip realm>> <401> ] if ;
+M: basic-auth-realm logged-in-username ( realm -- uid )
+ request get "authorization" header parse-basic-auth
+ dup [ over realm get check-login swap and ] [ 2drop f ] if ;
diff --git a/extra/furnace/auth/login/boilerplate.xml b/extra/furnace/auth/boilerplate.xml
similarity index 100%
rename from extra/furnace/auth/login/boilerplate.xml
rename to extra/furnace/auth/boilerplate.xml
diff --git a/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor b/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor
new file mode 100644
index 0000000000..d0fdf22c27
--- /dev/null
+++ b/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor
@@ -0,0 +1,4 @@
+IN: furnace.auth.features.edit-profile.tests
+USING: tools.test furnace.auth.features.edit-profile ;
+
+\ allow-edit-profile must-infer
diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.factor b/extra/furnace/auth/features/edit-profile/edit-profile.factor
new file mode 100644
index 0000000000..4edb4ac364
--- /dev/null
+++ b/extra/furnace/auth/features/edit-profile/edit-profile.factor
@@ -0,0 +1,67 @@
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences assocs
+validators urls
+html.forms
+http.server.dispatchers
+furnace.auth
+furnace.asides
+furnace.actions ;
+IN: furnace.auth.features.edit-profile
+
+: <edit-profile-action> ( -- action )
+ <page-action>
+ [
+ logged-in-user get
+ [ username>> "username" set-value ]
+ [ realname>> "realname" set-value ]
+ [ email>> "email" set-value ]
+ tri
+ ] >>init
+
+ { realm "features/edit-profile/edit-profile" } >>template
+
+ [
+ logged-in-user get username>> "username" set-value
+
+ {
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "password" [ ] }
+ { "new-password" [ [ v-password ] v-optional ] }
+ { "verify-password" [ [ v-password ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ } validate-params
+
+ { "password" "new-password" "verify-password" }
+ [ value empty? not ] contains? [
+ "password" value logged-in-user get username>> check-login
+ [ "incorrect password" validation-error ] unless
+
+ same-password-twice
+ ] when
+ ] >>validate
+
+ [
+ logged-in-user get
+
+ "new-password" value dup empty?
+ [ drop ] [ >>encoded-password ] if
+
+ "realname" value >>realname
+ "email" value >>email
+
+ t >>changed?
+
+ drop
+
+ URL" $login" end-aside
+ ] >>submit
+
+ <protected>
+ "edit your profile" >>description ;
+
+: allow-edit-profile ( login -- login )
+ <edit-profile-action> <auth-boilerplate> "edit-profile" add-responder ;
+
+: allow-edit-profile? ( -- ? )
+ realm get get responders>> "edit-profile" swap key? ;
diff --git a/extra/furnace/auth/login/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml
similarity index 100%
rename from extra/furnace/auth/login/edit-profile.xml
rename to extra/furnace/auth/features/edit-profile/edit-profile.xml
diff --git a/extra/furnace/auth/login/recover-1.xml b/extra/furnace/auth/features/recover-password/recover-1.xml
similarity index 100%
rename from extra/furnace/auth/login/recover-1.xml
rename to extra/furnace/auth/features/recover-password/recover-1.xml
diff --git a/extra/furnace/auth/login/recover-2.xml b/extra/furnace/auth/features/recover-password/recover-2.xml
similarity index 100%
rename from extra/furnace/auth/login/recover-2.xml
rename to extra/furnace/auth/features/recover-password/recover-2.xml
diff --git a/extra/furnace/auth/login/recover-3.xml b/extra/furnace/auth/features/recover-password/recover-3.xml
similarity index 100%
rename from extra/furnace/auth/login/recover-3.xml
rename to extra/furnace/auth/features/recover-password/recover-3.xml
diff --git a/extra/furnace/auth/login/recover-4.xml b/extra/furnace/auth/features/recover-password/recover-4.xml
similarity index 100%
rename from extra/furnace/auth/login/recover-4.xml
rename to extra/furnace/auth/features/recover-password/recover-4.xml
diff --git a/extra/furnace/auth/features/recover-password/recover-password-tests.factor b/extra/furnace/auth/features/recover-password/recover-password-tests.factor
new file mode 100644
index 0000000000..b589c52624
--- /dev/null
+++ b/extra/furnace/auth/features/recover-password/recover-password-tests.factor
@@ -0,0 +1,4 @@
+IN: furnace.auth.features.recover-password
+USING: tools.test furnace.auth.features.recover-password ;
+
+\ allow-password-recovery must-infer
diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor
new file mode 100644
index 0000000000..1e8d163e99
--- /dev/null
+++ b/extra/furnace/auth/features/recover-password/recover-password.factor
@@ -0,0 +1,123 @@
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces accessors kernel assocs arrays io.sockets threads
+fry urls smtp validators html.forms
+http http.server.responses http.server.dispatchers
+furnace furnace.actions furnace.auth furnace.auth.providers ;
+IN: furnace.auth.features.recover-password
+
+SYMBOL: lost-password-from
+
+: current-host ( -- string )
+ request get url>> host>> host-name or ;
+
+: new-password-url ( user -- url )
+ "recover-3"
+ swap [
+ [ username>> "username" set ]
+ [ ticket>> "ticket" set ]
+ bi
+ ] H{ } make-assoc
+ derive-url ;
+
+: password-email ( user -- email )
+ <email>
+ [ "[ " % current-host % " ] password recovery" % ] "" make >>subject
+ lost-password-from get >>from
+ over email>> 1array >>to
+ [
+ "This e-mail was sent by the application server on " % current-host % "\n" %
+ "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
+ "login form, and requested a new password for the user named ``" %
+ over username>> % "''.\n" %
+ "\n" %
+ "If you believe that this request was legitimate, you may click the below link in\n" %
+ "your browser to set a new password for your account:\n" %
+ "\n" %
+ swap new-password-url %
+ "\n\n" %
+ "Love,\n" %
+ "\n" %
+ " FactorBot\n" %
+ ] "" make >>body ;
+
+: send-password-email ( user -- )
+ '[ , password-email send-email ]
+ "E-mail send thread" spawn drop ;
+
+: <recover-action-1> ( -- action )
+ <page-action>
+ { realm "recover-1" } >>template
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "email" [ v-email ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
+ ] >>validate
+
+ [
+ "email" value "username" value
+ users issue-ticket [
+ send-password-email
+ ] when*
+
+ URL" $login/recover-2" <redirect>
+ ] >>submit ;
+
+: <recover-action-2> ( -- action )
+ <page-action>
+ { realm "recover-2" } >>template ;
+
+: <recover-action-3> ( -- action )
+ <page-action>
+ [
+ {
+ { "username" [ v-username ] }
+ { "ticket" [ v-required ] }
+ } validate-params
+ ] >>init
+
+ { realm "recover-3" } >>template
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "ticket" [ v-required ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ } validate-params
+
+ same-password-twice
+ ] >>validate
+
+ [
+ "ticket" value
+ "username" value
+ users claim-ticket [
+ "new-password" value >>encoded-password
+ users update-user
+
+ URL" $login/recover-4" <redirect>
+ ] [
+ <403>
+ ] if*
+ ] >>submit ;
+
+: <recover-action-4> ( -- action )
+ <page-action>
+ { realm "recover-4" } >>template ;
+
+: allow-password-recovery ( login -- login )
+ <recover-action-1> <auth-boilerplate>
+ "recover-password" add-responder
+ <recover-action-2> <auth-boilerplate>
+ "recover-2" add-responder
+ <recover-action-3> <auth-boilerplate>
+ "recover-3" add-responder
+ <recover-action-4> <auth-boilerplate>
+ "recover-4" add-responder ;
+
+: allow-password-recovery? ( -- ? )
+ realm get responders>> "recover-password" swap key? ;
diff --git a/extra/furnace/auth/login/register.xml b/extra/furnace/auth/features/registration/register.xml
similarity index 100%
rename from extra/furnace/auth/login/register.xml
rename to extra/furnace/auth/features/registration/register.xml
diff --git a/extra/furnace/auth/features/registration/registration-tests.factor b/extra/furnace/auth/features/registration/registration-tests.factor
new file mode 100644
index 0000000000..e770f35586
--- /dev/null
+++ b/extra/furnace/auth/features/registration/registration-tests.factor
@@ -0,0 +1,4 @@
+IN: furnace.auth.features.registration.tests
+USING: tools.test furnace.auth.features.registration ;
+
+\ allow-registration must-infer
diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor
new file mode 100644
index 0000000000..3deead4869
--- /dev/null
+++ b/extra/furnace/auth/features/registration/registration.factor
@@ -0,0 +1,43 @@
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel namespaces validators html.forms urls
+http.server.dispatchers
+furnace furnace.auth furnace.auth.providers furnace.actions ;
+IN: furnace.auth.features.registration
+
+: <register-action> ( -- action )
+ <page-action>
+ { realm "register" } >>template
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
+
+ same-password-twice
+ ] >>validate
+
+ [
+ "username" value <user>
+ "realname" value >>realname
+ "new-password" value >>encoded-password
+ "email" value >>email
+ H{ } clone >>profile
+
+ users new-user [ user-exists ] unless*
+
+ realm get init-user-profile
+
+ URL" $realm" <redirect>
+ ] >>submit ;
+
+: allow-registration ( login -- login )
+ <register-action> <auth-boilerplate> "register" add-responder ;
+
+: allow-registration? ( -- ? )
+ realm get responders>> "register" swap key? ;
diff --git a/extra/furnace/auth/login/login-tests.factor b/extra/furnace/auth/login/login-tests.factor
index 5095ebdb85..64f7bd3b96 100755
--- a/extra/furnace/auth/login/login-tests.factor
+++ b/extra/furnace/auth/login/login-tests.factor
@@ -1,6 +1,4 @@
IN: furnace.auth.login.tests
USING: tools.test furnace.auth.login ;
-\ <login> must-infer
-\ allow-registration must-infer
-\ allow-password-recovery must-infer
+\ <login-realm> must-infer
diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index 80005c452a..1f81c488cc 100755
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -1,103 +1,35 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors quotations assocs kernel splitting
-combinators sequences namespaces hashtables sets
-fry arrays threads qualified random validators words
-io
-io.sockets
-io.encodings.utf8
-io.encodings.string
-io.binary
-continuations
-destructors
-checksums
-checksums.sha2
-validators
+USING: kernel accessors namespaces validators urls
html.forms
-html.components
-html.elements
-urls
-http
-http.server
http.server.dispatchers
-http.server.filters
-http.server.responses
-furnace
furnace.auth
-furnace.auth.providers
-furnace.auth.providers.db
-furnace.actions
-furnace.asides
furnace.flash
+furnace.asides
+furnace.actions
furnace.sessions
-furnace.boilerplate ;
-QUALIFIED: smtp
+furnace.utilities ;
IN: furnace.auth.login
-: word>string ( word -- string )
- [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
+TUPLE: login-realm < realm ;
-: words>strings ( seq -- seq' )
- [ word>string ] map ;
+: set-uid ( username -- )
+ session get [ (>>uid) ] [ (session-changed) ] bi ;
-ERROR: no-such-word name vocab ;
-
-: string>word ( string -- word )
- ":" split1 swap 2dup lookup dup
- [ 2nip ] [ drop no-such-word ] if ;
-
-: strings>words ( seq -- seq' )
- [ string>word ] map ;
-
-TUPLE: login < dispatcher users checksum ;
-
-TUPLE: protected < filter-responder description capabilities ;
-
-: <protected> ( responder -- protected )
- protected new
- swap >>responder ;
-
-: users ( -- provider )
- login get users>> ;
-
-: encode-password ( string salt -- bytes )
- [ utf8 encode ] [ 4 >be ] bi* append
- login get checksum>> checksum-bytes ;
-
-: >>encoded-password ( user string -- user )
- 32 random-bits [ encode-password ] keep
- [ >>password ] [ >>salt ] bi* ; inline
-
-: valid-login? ( password user -- ? )
- [ salt>> encode-password ] [ password>> ] bi = ;
-
-: check-login ( password username -- user/f )
- users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
-
-! Destructor
-TUPLE: user-saver user ;
-
-C: <user-saver> user-saver
-
-M: user-saver dispose
- user>> dup changed?>> [ users update-user ] [ drop ] if ;
-
-: save-user-after ( user -- )
- <user-saver> &dispose drop ;
-
-! ! ! Login
: successful-login ( user -- response )
- username>> set-uid URL" $login" end-aside ;
+ username>> set-uid URL" $realm" end-aside ;
-: login-failed ( -- * )
- "invalid username or password" validation-error
- validation-failed ;
+: logout ( -- ) f set-uid ;
SYMBOL: description
SYMBOL: capabilities
: flashed-variables { description capabilities } ;
+: login-failed ( -- * )
+ "invalid username or password" validation-error
+ validation-failed ;
+
: <login-action> ( -- action )
<page-action>
[
@@ -106,7 +38,7 @@ SYMBOL: capabilities
capabilities get words>strings "capabilities" set-value
] >>init
- { login "login" } >>template
+ { login-realm "login" } >>template
[
{
@@ -119,286 +51,21 @@ SYMBOL: capabilities
[ successful-login ] [ login-failed ] if*
] >>submit ;
-! ! ! New user registration
-
-: user-exists ( -- * )
- "username taken" validation-error
- validation-failed ;
-
-: password-mismatch ( -- * )
- "passwords do not match" validation-error
- validation-failed ;
-
-: same-password-twice ( -- )
- "new-password" value "verify-password" value =
- [ password-mismatch ] unless ;
-
-: <register-action> ( -- action )
- <page-action>
- { login "register" } >>template
-
- [
- {
- { "username" [ v-username ] }
- { "realname" [ [ v-one-line ] v-optional ] }
- { "new-password" [ v-password ] }
- { "verify-password" [ v-password ] }
- { "email" [ [ v-email ] v-optional ] }
- { "captcha" [ v-captcha ] }
- } validate-params
-
- same-password-twice
- ] >>validate
-
- [
- "username" value <user>
- "realname" value >>realname
- "new-password" value >>encoded-password
- "email" value >>email
- H{ } clone >>profile
-
- users new-user [ user-exists ] unless*
-
- login get init-user-profile
-
- successful-login
- ] >>submit ;
-
-! ! ! Editing user profile
-
-: <edit-profile-action> ( -- action )
- <page-action>
- [
- logged-in-user get
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- tri
- ] >>init
-
- { login "edit-profile" } >>template
-
- [
- uid "username" set-value
-
- {
- { "realname" [ [ v-one-line ] v-optional ] }
- { "password" [ ] }
- { "new-password" [ [ v-password ] v-optional ] }
- { "verify-password" [ [ v-password ] v-optional ] }
- { "email" [ [ v-email ] v-optional ] }
- } validate-params
-
- { "password" "new-password" "verify-password" }
- [ value empty? not ] contains? [
- "password" value uid check-login
- [ "incorrect password" validation-error ] unless
-
- same-password-twice
- ] when
- ] >>validate
-
- [
- logged-in-user get
-
- "new-password" value dup empty?
- [ drop ] [ >>encoded-password ] if
-
- "realname" value >>realname
- "email" value >>email
-
- t >>changed?
-
- drop
-
- URL" $login" end-aside
- ] >>submit
-
- <protected>
- "edit your profile" >>description ;
-
-! ! ! Password recovery
-
-SYMBOL: lost-password-from
-
-: current-host ( -- string )
- request get url>> host>> host-name or ;
-
-: new-password-url ( user -- url )
- "recover-3"
- swap [
- [ username>> "username" set ]
- [ ticket>> "ticket" set ]
- bi
- ] H{ } make-assoc
- derive-url ;
-
-: password-email ( user -- email )
- smtp:<email>
- [ "[ " % current-host % " ] password recovery" % ] "" make >>subject
- lost-password-from get >>from
- over email>> 1array >>to
- [
- "This e-mail was sent by the application server on " % current-host % "\n" %
- "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
- "login form, and requested a new password for the user named ``" %
- over username>> % "''.\n" %
- "\n" %
- "If you believe that this request was legitimate, you may click the below link in\n" %
- "your browser to set a new password for your account:\n" %
- "\n" %
- swap new-password-url %
- "\n\n" %
- "Love,\n" %
- "\n" %
- " FactorBot\n" %
- ] "" make >>body ;
-
-: send-password-email ( user -- )
- '[ , password-email smtp:send-email ]
- "E-mail send thread" spawn drop ;
-
-: <recover-action-1> ( -- action )
- <page-action>
- { login "recover-1" } >>template
-
- [
- {
- { "username" [ v-username ] }
- { "email" [ v-email ] }
- { "captcha" [ v-captcha ] }
- } validate-params
- ] >>validate
-
- [
- "email" value "username" value
- users issue-ticket [
- send-password-email
- ] when*
-
- URL" $login/recover-2" <redirect>
- ] >>submit ;
-
-: <recover-action-2> ( -- action )
- <page-action>
- { login "recover-2" } >>template ;
-
-: <recover-action-3> ( -- action )
- <page-action>
- [
- {
- { "username" [ v-username ] }
- { "ticket" [ v-required ] }
- } validate-params
- ] >>init
-
- { login "recover-3" } >>template
-
- [
- {
- { "username" [ v-username ] }
- { "ticket" [ v-required ] }
- { "new-password" [ v-password ] }
- { "verify-password" [ v-password ] }
- } validate-params
-
- same-password-twice
- ] >>validate
-
- [
- "ticket" value
- "username" value
- users claim-ticket [
- "new-password" value >>encoded-password
- users update-user
-
- URL" $login/recover-4" <redirect>
- ] [
- <403>
- ] if*
- ] >>submit ;
-
-: <recover-action-4> ( -- action )
- <page-action>
- { login "recover-4" } >>template ;
-
-! ! ! Logout
: <logout-action> ( -- action )
<action>
- [
- f set-uid
- URL" $login" end-aside
- ] >>submit ;
+ [ logout URL" $login-realm" end-aside ] >>submit ;
-! ! ! Authentication logic
-: show-login-page ( -- response )
+M: login-realm login-required*
+ drop
begin-aside
protected get description>> description set
protected get capabilities>> capabilities set
URL" $login/login" flashed-variables <flash-redirect> ;
-: login-required ( -- * )
- show-login-page exit-with ;
+M: login-realm logged-in-username
+ drop session get uid>> ;
-: have-capability? ( capability -- ? )
- logged-in-user get capabilities>> member? ;
-
-: check-capabilities ( responder user/f -- ? )
- dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ;
-
-M: protected call-responder* ( path responder -- response )
- dup protected set
- dup logged-in-user get check-capabilities
- [ call-next-method ] [ 2drop show-login-page ] if ;
-
-: init-user ( -- )
- uid [
- users get-user
- [ logged-in-user set ]
- [ save-user-after ] bi
- ] when* ;
-
-M: login call-responder* ( path responder -- response )
- dup login set
- init-user
- call-next-method ;
-
-: <login-boilerplate> ( responder -- responder' )
- <boilerplate>
- { login "boilerplate" } >>template ;
-
-: <login> ( responder -- auth )
- login new-dispatcher
- swap >>default
- <login-action> <login-boilerplate> "login" add-responder
- <logout-action> <login-boilerplate> "logout" add-responder
- users-in-db >>users
- sha-256 >>checksum ;
-
-! ! ! Configuration
-
-: allow-edit-profile ( login -- login )
- <edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;
-
-: allow-registration ( login -- login )
- <register-action> <login-boilerplate>
- "register" add-responder ;
-
-: allow-password-recovery ( login -- login )
- <recover-action-1> <login-boilerplate>
- "recover-password" add-responder
- <recover-action-2> <login-boilerplate>
- "recover-2" add-responder
- <recover-action-3> <login-boilerplate>
- "recover-3" add-responder
- <recover-action-4> <login-boilerplate>
- "recover-4" add-responder ;
-
-: allow-edit-profile? ( -- ? )
- login get responders>> "edit-profile" swap key? ;
-
-: allow-registration? ( -- ? )
- login get responders>> "register" swap key? ;
-
-: allow-password-recovery? ( -- ? )
- login get responders>> "recover-password" swap key? ;
+: <login-realm> ( responder name -- auth )
+ login-realm new-realm
+ <login-action> <auth-boilerplate> "login" add-responder
+ <logout-action> "logout" add-responder ;
diff --git a/extra/furnace/auth/providers/db/db-tests.factor b/extra/furnace/auth/providers/db/db-tests.factor
index e5914c7ab3..fac5c23e4a 100755
--- a/extra/furnace/auth/providers/db/db-tests.factor
+++ b/extra/furnace/auth/providers/db/db-tests.factor
@@ -1,14 +1,13 @@
IN: furnace.auth.providers.db.tests
USING: furnace.actions
+furnace.auth
furnace.auth.login
furnace.auth.providers
furnace.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files accessors kernel ;
-<action> <login>
- users-in-db >>users
-login set
+<action> "test" <login-realm> realm set
[ "auth-test.db" temp-file delete-file ] ignore-errors
diff --git a/extra/furnace/db/db.factor b/extra/furnace/db/db.factor
index 8487b4b3fc..b4a4386015 100755
--- a/extra/furnace/db/db.factor
+++ b/extra/furnace/db/db.factor
@@ -1,8 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors continuations namespaces destructors
-db db.pools io.pools http.server http.server.filters
-furnace.sessions ;
+db db.pools io.pools http.server http.server.filters ;
IN: furnace.db
TUPLE: db-persistence < filter-responder pool ;
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index 4be7403e39..fe8053fc9c 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -57,12 +57,6 @@ TUPLE: sessions < server-state-manager domain verify? ;
[ namespace>> swap change-at ] keep
(session-changed) ; inline
-: uid ( -- uid )
- session get uid>> ;
-
-: set-uid ( uid -- )
- session get [ (>>uid) ] [ (session-changed) ] bi ;
-
: init-session ( session -- )
session [ sessions get init-session* ] with-variable ;
@@ -147,6 +141,3 @@ M: sessions call-responder* ( path responder -- response )
sessions set
request-session [ begin-session ] unless*
existing-session put-session-cookie ;
-
-: logout-all-sessions ( uid -- )
- session new swap >>uid delete-tuples ;
diff --git a/extra/furnace/utilities/utilities.factor b/extra/furnace/utilities/utilities.factor
new file mode 100644
index 0000000000..20c05d459f
--- /dev/null
+++ b/extra/furnace/utilities/utilities.factor
@@ -0,0 +1,19 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel sequences splitting ;
+IN: furnace.utilities
+
+: word>string ( word -- string )
+ [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
+
+: words>strings ( seq -- seq' )
+ [ word>string ] map ;
+
+ERROR: no-such-word name vocab ;
+
+: string>word ( string -- word )
+ ":" split1 swap 2dup lookup dup
+ [ 2nip ] [ drop no-such-word ] if ;
+
+: strings>words ( seq -- seq' )
+ [ string>word ] map ;
diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor
index daf4ad88d3..28a605174a 100755
--- a/extra/http/client/client-tests.factor
+++ b/extra/http/client/client-tests.factor
@@ -14,7 +14,7 @@ tuple-syntax namespaces urls ;
method: "GET"
version: "1.1"
cookies: V{ }
- header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
+ header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
}
] [
"http://www.apple.com/index.html"
@@ -27,7 +27,7 @@ tuple-syntax namespaces urls ;
method: "GET"
version: "1.1"
cookies: V{ }
- header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
+ header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
}
] [
"https://www.amazon.com/index.html"
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index d092e5008f..73d26aa327 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -122,7 +122,7 @@ read-response-test-1' 1array [
! Live-fire exercise
USING: http.server http.server.static furnace.sessions furnace.alloy
-furnace.actions furnace.auth.login furnace.db http.client
+furnace.actions furnace.auth furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii
accessors namespaces threads
http.server.responses http.server.redirection
@@ -176,7 +176,7 @@ test-db [
[
<dispatcher>
<action> <protected>
- <login>
+ "Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
@@ -206,7 +206,7 @@ test-db [
[
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
- <login>
+ "Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 25bf20429d..d2a0b0f922 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -147,7 +147,7 @@ cookies ;
H{ } clone >>header
V{ } clone >>cookies
"close" "connection" set-header
- "Factor http.client vocabulary" "user-agent" set-header ;
+ "Factor http.client" "user-agent" set-header ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
@@ -296,6 +296,7 @@ body ;
H{ } clone >>header
"close" "connection" set-header
now timestamp>http-string "date" set-header
+ "Factor http.server" "server" set-header
latin1 >>content-charset
V{ } clone >>cookies ;
diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor
index 760951eec6..aa1aa5edc7 100644
--- a/extra/webapps/blogs/blogs.factor
+++ b/extra/webapps/blogs/blogs.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math.order math.parser
-urls validators db db.types db.tuples calendar present
+urls validators db db.types db.tuples calendar present namespaces
html.forms
html.components
http.server.dispatchers
@@ -10,7 +10,6 @@ furnace.actions
furnace.auth
furnace.auth.login
furnace.boilerplate
-furnace.sessions
furnace.syndication ;
IN: webapps.blogs
@@ -160,13 +159,13 @@ M: comment entity-url
[
validate-post
- uid "author" set-value
+ logged-in-user get username>> "author" set-value
] >>validate
[
f <post>
dup { "title" "content" } to-object
- uid >>author
+ logged-in-user get username>> >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
@@ -177,7 +176,8 @@ M: comment entity-url
"make a new blog post" >>description ;
: authorize-author ( author -- )
- uid = can-administer-blogs? have-capability? or
+ logged-in-user get username>> =
+ can-administer-blogs? have-capability? or
[ login-required ] unless ;
: do-post-action ( -- )
@@ -253,13 +253,13 @@ M: comment entity-url
[
validate-comment
- uid "author" set-value
+ logged-in-user get username>> "author" set-value
] >>validate
[
"parent" value f <comment>
"content" value >>content
- uid >>author
+ logged-in-user get username>> >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
index 04fc0487b8..c0bd856d5d 100644
--- a/extra/webapps/factor-website/factor-website.factor
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -7,12 +7,11 @@ logging.insomniac
http.server
http.server.dispatchers
furnace.alloy
-furnace.db
-furnace.asides
-furnace.flash
-furnace.sessions
furnace.auth.login
furnace.auth.providers.db
+furnace.auth.features.edit-profile
+furnace.auth.features.recover-password
+furnace.auth.features.registration
furnace.boilerplate
webapps.blogs
webapps.pastebin
@@ -50,8 +49,8 @@ TUPLE: factor-website < dispatcher ;
<wiki> "wiki" add-responder
<wee-url> "wee-url" add-responder
<user-admin> "user-admin" add-responder
- <login>
- users-in-db >>users
+ "Factor website" <login-realm>
+ "Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index dba10184f4..4b1b59e80f 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -8,7 +8,6 @@ html.templates.chloe
http.server
http.server.dispatchers
furnace
-furnace.sessions
furnace.boilerplate
furnace.auth
furnace.actions
@@ -32,7 +31,7 @@ todo "TODO"
: <todo> ( id -- todo )
todo new
swap >>id
- uid >>uid ;
+ logged-in-user get username>> >>uid ;
: <view-action> ( -- action )
<page-action>
diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor
index 5859d616ee..8c7b1b21c9 100644
--- a/extra/webapps/user-admin/user-admin.factor
+++ b/extra/webapps/user-admin/user-admin.factor
@@ -11,8 +11,8 @@ furnace.auth.providers
furnace.auth.providers.db
furnace.auth.login
furnace.auth
-furnace.sessions
furnace.actions
+furnace.utilities
http.server
http.server.dispatchers ;
IN: webapps.user-admin
@@ -138,11 +138,7 @@ TUPLE: user-admin < dispatcher ;
<action>
[
validate-username
-
- [ <user> select-tuple 1 >>deleted update-tuple ]
- [ logout-all-sessions ]
- bi
-
+ <user> select-tuple 1 >>deleted update-tuple
URL" $user-admin" <redirect>
] >>submit ;
From 65b8e375df14cf33eb8563e71861ed1001280ee1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Jun 2008 03:34:23 -0500
Subject: [PATCH 56/90] Documentation fix
---
core/inference/inference-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor
index 5900e5a844..7d43187f54 100755
--- a/core/inference/inference-docs.factor
+++ b/core/inference/inference-docs.factor
@@ -92,7 +92,7 @@ ARTICLE: "inference-errors" "Inference errors"
{ $subsection missing-effect } ;
ARTICLE: "inference" "Stack effect inference"
-"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
+"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
$nl
"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:"
{ $subsection infer. }
From 73105cc043b425ce92ee283cb65a60fa4579bd05 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Jun 2008 03:46:54 -0500
Subject: [PATCH 57/90] Debugging furnace.auth refactoring
---
extra/furnace/auth/auth.factor | 4 +++-
.../auth/features/edit-profile/edit-profile.factor | 2 +-
.../auth/features/edit-profile/edit-profile.xml | 2 +-
extra/furnace/auth/login/login.factor | 12 ++++++------
extra/furnace/auth/login/login.xml | 4 ++--
extra/furnace/furnace.factor | 2 +-
extra/webapps/blogs/blogs-common.xml | 8 ++++----
extra/webapps/pastebin/pastebin-common.xml | 8 ++++----
extra/webapps/planet/planet-common.xml | 8 ++++----
extra/webapps/todo/todo.xml | 6 +++---
extra/webapps/user-admin/user-admin.xml | 6 +++---
extra/webapps/wiki/wiki-common.xml | 8 ++++----
12 files changed, 36 insertions(+), 34 deletions(-)
diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor
index d10ba48ce5..9bb7ea105e 100755
--- a/extra/furnace/auth/auth.factor
+++ b/extra/furnace/auth/auth.factor
@@ -17,6 +17,8 @@ IN: furnace.auth
SYMBOL: logged-in-user
+: logged-in? ( -- ? ) logged-in-user get >boolean ;
+
GENERIC: init-user-profile ( responder -- )
M: object init-user-profile drop ;
@@ -114,7 +116,7 @@ TUPLE: protected < filter-responder description capabilities ;
: check-capabilities ( responder user/f -- ? )
{
{ [ dup not ] [ 2drop f ] }
- { [ dup deleted>> ] [ 2drop f ] }
+ { [ dup deleted>> 1 = ] [ 2drop f ] }
[ [ capabilities>> ] bi@ subset? ]
} cond ;
diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.factor b/extra/furnace/auth/features/edit-profile/edit-profile.factor
index 4edb4ac364..e03fca99a5 100644
--- a/extra/furnace/auth/features/edit-profile/edit-profile.factor
+++ b/extra/furnace/auth/features/edit-profile/edit-profile.factor
@@ -64,4 +64,4 @@ IN: furnace.auth.features.edit-profile
<edit-profile-action> <auth-boilerplate> "edit-profile" add-responder ;
: allow-edit-profile? ( -- ? )
- realm get get responders>> "edit-profile" swap key? ;
+ realm get responders>> "edit-profile" swap key? ;
diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml
index 6beaf5de6d..011cc2bdf8 100644
--- a/extra/furnace/auth/features/edit-profile/edit-profile.xml
+++ b/extra/furnace/auth/features/edit-profile/edit-profile.xml
@@ -4,7 +4,7 @@
<t:title>Edit Profile</t:title>
- <t:form t:action="$login/edit-profile">
+ <t:form t:action="$realm/edit-profile">
<table>
diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index 1f81c488cc..6a59c01c63 100755
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -13,13 +13,16 @@ IN: furnace.auth.login
TUPLE: login-realm < realm ;
+M: login-realm logged-in-username
+ drop session get uid>> ;
+
: set-uid ( username -- )
session get [ (>>uid) ] [ (session-changed) ] bi ;
: successful-login ( user -- response )
username>> set-uid URL" $realm" end-aside ;
-: logout ( -- ) f set-uid ;
+: logout ( -- ) f set-uid URL" $realm" end-aside ;
SYMBOL: description
SYMBOL: capabilities
@@ -53,17 +56,14 @@ SYMBOL: capabilities
: <logout-action> ( -- action )
<action>
- [ logout URL" $login-realm" end-aside ] >>submit ;
+ [ logout ] >>submit ;
M: login-realm login-required*
drop
begin-aside
protected get description>> description set
protected get capabilities>> capabilities set
- URL" $login/login" flashed-variables <flash-redirect> ;
-
-M: login-realm logged-in-username
- drop session get uid>> ;
+ URL" $realm/login" flashed-variables <flash-redirect> ;
: <login-realm> ( responder name -- auth )
login-realm new-realm
diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml
index a7ac92bf44..81f9520e76 100644
--- a/extra/furnace/auth/login/login.xml
+++ b/extra/furnace/auth/login/login.xml
@@ -43,11 +43,11 @@
</t:form>
<p>
- <t:if t:code="furnace.auth.login:allow-registration?">
+ <t:if t:code="furnace.auth.features.registration:allow-registration?">
<t:a t:href="register">Register</t:a>
</t:if>
|
- <t:if t:code="furnace.auth.login:allow-password-recovery?">
+ <t:if t:code="furnace.auth.features.recover-password:allow-password-recovery?">
<t:a t:href="recover-password">Recover Password</t:a>
</t:if>
</p>
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index e9d1b29da8..6b47bc681b 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -31,7 +31,7 @@ IN: furnace
: base-path ( string -- pair )
dup responder-nesting get
- [ second class word-name = ] with find nip
+ [ second class superclasses [ word-name = ] with contains? ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml
index 965f059abd..e809c0e7f5 100644
--- a/extra/webapps/blogs/blogs-common.xml
+++ b/extra/webapps/blogs/blogs-common.xml
@@ -12,13 +12,13 @@
| <t:a t:href="$blogs/by">My Posts</t:a>
| <t:a t:href="$blogs/new-post">New Post</t:a>
- <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth:logged-in?">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml
index 47f7666b22..b95f3f7b64 100644
--- a/extra/webapps/pastebin/pastebin-common.xml
+++ b/extra/webapps/pastebin/pastebin-common.xml
@@ -11,13 +11,13 @@
<t:a t:href="$pastebin/list">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
- <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth:logged-in?">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml
index 34ee73da67..6c0affd17f 100644
--- a/extra/webapps/planet/planet-common.xml
+++ b/extra/webapps/planet/planet-common.xml
@@ -9,12 +9,12 @@
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
- <t:if t:code="furnace.sessions:uid">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth:logged-in?">
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
</div>
diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml
index e087fbfcfc..f7500cdad2 100644
--- a/extra/webapps/todo/todo.xml
+++ b/extra/webapps/todo/todo.xml
@@ -8,11 +8,11 @@
<t:a t:href="$todo-list/list">List Items</t:a>
| <t:a t:href="$todo-list/new">Add Item</t:a>
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml
index 9cb9ef0a0a..2141fdc1d9 100644
--- a/extra/webapps/user-admin/user-admin.xml
+++ b/extra/webapps/user-admin/user-admin.xml
@@ -6,11 +6,11 @@
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml
index 1d08d3832d..0abd36a7cd 100644
--- a/extra/webapps/wiki/wiki-common.xml
+++ b/extra/webapps/wiki/wiki-common.xml
@@ -14,13 +14,13 @@
| <t:a t:href="$wiki/articles">All Articles</t:a>
| <t:a t:href="$wiki/changes">Recent Changes</t:a>
- <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth:logged-in?">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
From c5a96c093b1a628300a669dc2cc0cfad02b34e42 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Jun 2008 05:16:21 -0500
Subject: [PATCH 58/90] Clean up base64 add add more tets
---
extra/base64/base64-tests.factor | 20 +++++++++++++++-----
extra/base64/base64.factor | 27 ++++++++++++---------------
2 files changed, 27 insertions(+), 20 deletions(-)
diff --git a/extra/base64/base64-tests.factor b/extra/base64/base64-tests.factor
index d867351f8b..86c58af505 100644
--- a/extra/base64/base64-tests.factor
+++ b/extra/base64/base64-tests.factor
@@ -1,8 +1,18 @@
USING: kernel tools.test base64 strings ;
-[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
+[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
] unit-test
-[ "" ] [ "" >base64 base64> ] unit-test
-[ "a" ] [ "a" >base64 base64> ] unit-test
-[ "ab" ] [ "ab" >base64 base64> ] unit-test
-[ "abc" ] [ "abc" >base64 base64> ] unit-test
+[ "" ] [ "" >base64 base64> >string ] unit-test
+[ "a" ] [ "a" >base64 base64> >string ] unit-test
+[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
+[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
+
+! From http://en.wikipedia.org/wiki/Base64
+[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
+[
+ "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
+ >base64 >string
+] unit-test
+
+\ >base64 must-infer
+\ base64> must-infer
diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor
index 600a8f4c3d..d48abc2014 100644
--- a/extra/base64/base64.factor
+++ b/extra/base64/base64.factor
@@ -1,11 +1,10 @@
-USING: kernel math sequences namespaces io.binary splitting
-grouping strings hashtables ;
+USING: kernel math sequences io.binary splitting grouping ;
IN: base64
<PRIVATE
: count-end ( seq quot -- count )
- >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ;
+ >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline
: ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
@@ -20,28 +19,26 @@ IN: base64
} nth ;
: encode3 ( seq -- seq )
- be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ;
+ be> 4 <reversed> [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ;
: decode4 ( str -- str )
- [ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ;
+ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
: >base64-rem ( str -- str )
- [ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ;
+ [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ;
PRIVATE>
: >base64 ( seq -- base64 )
#! cut string into two pieces, convert 3 bytes at a time
#! pad string with = when not enough bits
- dup length dup 3 mod - cut swap
- [
- 3 <groups> [ encode3 % ] each
- dup empty? [ drop ] [ >base64-rem % ] if
- ] "" make ;
+ dup length dup 3 mod - cut
+ [ 3 <groups> [ encode3 ] map concat ]
+ [ dup empty? [ drop "" ] [ >base64-rem ] if ]
+ bi* append ;
: base64> ( base64 -- str )
#! input length must be a multiple of 4
- [
- [ 4 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end
- ] SBUF" " make swap [ dup pop* ] times >string ;
-
+ [ 4 <groups> [ decode4 ] map concat ]
+ [ [ CHAR: = = not ] count-end ]
+ bi head* ;
From e47e7ec30c1b980a13118df8b0919476ca34680a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Jun 2008 05:16:51 -0500
Subject: [PATCH 59/90] Login authentication is now stored outside of the
session, allowing multiple independent login realms per site
---
extra/furnace/alloy/alloy.factor | 5 +-
extra/furnace/auth/auth-tests.factor | 6 ++
extra/furnace/auth/auth.factor | 9 +--
extra/furnace/auth/basic/basic.factor | 10 ++--
.../features/registration/registration.factor | 2 +-
extra/furnace/auth/login/login.factor | 56 +++++++++++++++----
.../furnace/auth/login/permits/permits.factor | 30 ++++++++++
.../auth/providers/assoc/assoc-tests.factor | 6 +-
extra/furnace/furnace.factor | 13 +++++
extra/furnace/sessions/sessions.factor | 24 ++------
extra/http/http.factor | 12 +++-
extra/http/server/static/static.factor | 2 +-
extra/webapps/wiki/wiki.factor | 7 ++-
13 files changed, 131 insertions(+), 51 deletions(-)
create mode 100644 extra/furnace/auth/auth-tests.factor
create mode 100644 extra/furnace/auth/login/permits/permits.factor
diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor
index 14ffbaba9d..28c34e6715 100644
--- a/extra/furnace/alloy/alloy.factor
+++ b/extra/furnace/alloy/alloy.factor
@@ -7,7 +7,8 @@ furnace.flash
furnace.sessions
furnace.referrer
furnace.db
-furnace.auth.providers ;
+furnace.auth.providers
+furnace.auth.login.permits ;
IN: furnace.alloy
: <alloy> ( responder db params -- responder' )
@@ -19,7 +20,7 @@ IN: furnace.alloy
<check-form-submissions>
] call ;
-: state-classes { session flash-scope aside } ; inline
+: state-classes { session flash-scope aside permit } ; inline
: init-furnace-tables ( -- )
state-classes ensure-tables
diff --git a/extra/furnace/auth/auth-tests.factor b/extra/furnace/auth/auth-tests.factor
new file mode 100644
index 0000000000..220a8cd04c
--- /dev/null
+++ b/extra/furnace/auth/auth-tests.factor
@@ -0,0 +1,6 @@
+USING: furnace.auth tools.test ;
+IN: furnace.auth.tests
+
+\ logged-in-username must-infer
+\ <protected> must-infer
+\ new-realm must-infer
diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor
index 9bb7ea105e..d9f517aaf4 100755
--- a/extra/furnace/auth/auth.factor
+++ b/extra/furnace/auth/auth.factor
@@ -82,15 +82,12 @@ M: user-saver dispose
: save-user-after ( user -- )
<user-saver> &dispose drop ;
-: init-user ( realm -- )
- logged-in-username [
- users get-user
- [ logged-in-user set ] [ save-user-after ] bi
- ] when* ;
+: init-user ( user -- )
+ [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
M: realm call-responder* ( path responder -- response )
dup realm set
- dup init-user
+ dup logged-in-username dup [ users get-user ] when init-user
call-next-method ;
: encode-password ( string salt -- bytes )
diff --git a/extra/furnace/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor
index ae9cbb82c1..e478f70dcc 100755
--- a/extra/furnace/auth/basic/basic.factor
+++ b/extra/furnace/auth/basic/basic.factor
@@ -1,17 +1,18 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel splitting base64 namespaces
+USING: accessors kernel splitting base64 namespaces strings
http http.server.responses furnace.auth ;
IN: furnace.auth.basic
TUPLE: basic-auth-realm < realm ;
-C: <basic-auth-realm> basic-auth-realm
+: <basic-auth-realm> ( responder name -- realm )
+ basic-auth-realm new-realm ;
: parse-basic-auth ( header -- username/f password/f )
dup [
" " split1 swap "Basic" = [
- base64> ":" split1
+ base64> >string ":" split1
] [ drop f f ] if
] [ drop f f ] if ;
@@ -23,5 +24,6 @@ M: basic-auth-realm login-required* ( realm -- response )
name>> <401> ;
M: basic-auth-realm logged-in-username ( realm -- uid )
+ drop
request get "authorization" header parse-basic-auth
- dup [ over realm get check-login swap and ] [ 2drop f ] if ;
+ dup [ over check-login swap and ] [ 2drop f ] if ;
diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor
index 3deead4869..2bc7688b10 100644
--- a/extra/furnace/auth/features/registration/registration.factor
+++ b/extra/furnace/auth/features/registration/registration.factor
@@ -7,7 +7,7 @@ IN: furnace.auth.features.registration
: <register-action> ( -- action )
<page-action>
- { realm "register" } >>template
+ { realm "features/registration/register" } >>template
[
{
diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index 6a59c01c63..e2b208de3a 100755
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -1,28 +1,57 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces validators urls
-html.forms
-http.server.dispatchers
+USING: kernel accessors namespaces sequences math.parser
+calendar validators urls html.forms
+http http.server http.server.dispatchers
+furnace
furnace.auth
furnace.flash
furnace.asides
furnace.actions
furnace.sessions
-furnace.utilities ;
+furnace.utilities
+furnace.auth.login.permits ;
IN: furnace.auth.login
-TUPLE: login-realm < realm ;
+SYMBOL: permit-id
+
+: permit-id-key ( realm -- string )
+ [ >hex 2 CHAR: 0 pad-left ] { } map-as concat
+ "__p_" prepend ;
+
+: client-permit-id ( realm -- id/f )
+ permit-id-key client-state dup [ string>number ] when ;
+
+TUPLE: login-realm < realm timeout domain ;
+
+M: login-realm call-responder*
+ [ name>> client-permit-id permit-id set ]
+ [ call-next-method ]
+ bi ;
M: login-realm logged-in-username
- drop session get uid>> ;
+ drop permit-id get dup [ get-permit-uid ] when ;
-: set-uid ( username -- )
- session get [ (>>uid) ] [ (session-changed) ] bi ;
+M: login-realm modify-form ( responder -- )
+ drop permit-id get realm get name>> permit-id-key hidden-form-field ;
+
+: <permit-cookie> ( -- cookie )
+ permit-id get realm get name>> permit-id-key <cookie>
+ "$login-realm" resolve-base-path >>path
+ realm get timeout>> from-now >>expires
+ realm get domain>> >>domain ;
+
+: put-permit-cookie ( response -- response' )
+ <permit-cookie> put-cookie ;
: successful-login ( user -- response )
- username>> set-uid URL" $realm" end-aside ;
+ [ username>> make-permit permit-id set ] [ init-user ] bi
+ URL" $realm" end-aside
+ put-permit-cookie ;
-: logout ( -- ) f set-uid URL" $realm" end-aside ;
+: logout ( -- )
+ permit-id get [ delete-permit ] when*
+ URL" $realm" end-aside ;
SYMBOL: description
SYMBOL: capabilities
@@ -56,7 +85,9 @@ SYMBOL: capabilities
: <logout-action> ( -- action )
<action>
- [ logout ] >>submit ;
+ [ logout ] >>submit
+ <protected>
+ "logout" >>description ;
M: login-realm login-required*
drop
@@ -68,4 +99,5 @@ M: login-realm login-required*
: <login-realm> ( responder name -- auth )
login-realm new-realm
<login-action> <auth-boilerplate> "login" add-responder
- <logout-action> "logout" add-responder ;
+ <logout-action> "logout" add-responder
+ 20 minutes >>timeout ;
diff --git a/extra/furnace/auth/login/permits/permits.factor b/extra/furnace/auth/login/permits/permits.factor
new file mode 100644
index 0000000000..49cf98e0e3
--- /dev/null
+++ b/extra/furnace/auth/login/permits/permits.factor
@@ -0,0 +1,30 @@
+USING: accessors namespaces combinators.lib kernel
+db.tuples db.types
+furnace.auth furnace.sessions furnace.cache ;
+IN: furnace.auth.login.permits
+
+TUPLE: permit < server-state session uid ;
+
+permit "PERMITS" {
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "uid" "UID" { VARCHAR 255 } +not-null+ }
+} define-persistent
+
+: touch-permit ( permit -- )
+ realm get touch-state ;
+
+: get-permit-uid ( id -- uid )
+ permit get-state {
+ [ ]
+ [ session>> session get id>> = ]
+ [ [ touch-permit ] [ uid>> ] bi ]
+ } 1&& ;
+
+: make-permit ( uid -- id )
+ permit new
+ swap >>uid
+ session get id>> >>session
+ [ touch-permit ] [ insert-tuple ] [ id>> ] tri ;
+
+: delete-permit ( id -- )
+ permit new-server-state delete-tuples ;
diff --git a/extra/furnace/auth/providers/assoc/assoc-tests.factor b/extra/furnace/auth/providers/assoc/assoc-tests.factor
index 8f9eeaa7a5..8fe1dd4dd4 100755
--- a/extra/furnace/auth/providers/assoc/assoc-tests.factor
+++ b/extra/furnace/auth/providers/assoc/assoc-tests.factor
@@ -1,11 +1,11 @@
IN: furnace.auth.providers.assoc.tests
-USING: furnace.actions furnace.auth.providers
+USING: furnace.actions furnace.auth furnace.auth.providers
furnace.auth.providers.assoc furnace.auth.login
tools.test namespaces accessors kernel ;
-<action> <login>
+<action> "Test" <login-realm>
<users-in-memory> >>users
-login set
+realm set
[ t ] [
"slava" <user>
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 6b47bc681b..521f8a3bc1 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -96,6 +96,19 @@ M: object modify-form drop ;
request get url>>
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
+: cookie-client-state ( key request -- value/f )
+ swap get-cookie dup [ value>> ] when ;
+
+: post-client-state ( key request -- value/f )
+ request-params at ;
+
+: client-state ( key -- value/f )
+ request get dup method>> {
+ { "GET" [ cookie-client-state ] }
+ { "HEAD" [ cookie-client-state ] }
+ { "POST" [ post-client-state ] }
+ } case ;
+
SYMBOL: exit-continuation
: exit-with ( value -- )
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index fe8053fc9c..bb0a844269 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -98,20 +98,6 @@ M: session-saver dispose
: session-id-key "__s" ;
-: cookie-session-id ( request -- id/f )
- session-id-key get-cookie
- dup [ value>> string>number ] when ;
-
-: post-session-id ( request -- id/f )
- session-id-key swap request-params at string>number ;
-
-: request-session-id ( -- id/f )
- request get dup method>> {
- { "GET" [ cookie-session-id ] }
- { "HEAD" [ cookie-session-id ] }
- { "POST" [ post-session-id ] }
- } case ;
-
: verify-session ( session -- session )
sessions get verify?>> [
dup [
@@ -123,16 +109,18 @@ M: session-saver dispose
] when ;
: request-session ( -- session/f )
- request-session-id get-session verify-session ;
+ session-id-key
+ client-state dup [ string>number ] when
+ get-session verify-session ;
-: <session-cookie> ( id -- cookie )
- session-id-key <cookie>
+: <session-cookie> ( -- cookie )
+ session get id>> session-id-key <cookie>
"$sessions" resolve-base-path >>path
sessions get timeout>> from-now >>expires
sessions get domain>> >>domain ;
: put-session-cookie ( response -- response' )
- session get id>> number>string <session-cookie> put-cookie ;
+ <session-cookie> put-cookie ;
M: sessions modify-form ( responder -- )
drop session get id>> session-id-key hidden-form-field ;
diff --git a/extra/http/http.factor b/extra/http/http.factor
index d2a0b0f922..025e2c8441 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -99,23 +99,29 @@ TUPLE: cookie name value path domain expires max-age http-only ;
drop
] { } make ;
+: check-cookie-string ( string -- string' )
+ dup "=;'\"" intersect empty?
+ [ "Bad cookie name or value" throw ] unless ;
+
: (unparse-cookie) ( key value -- )
{
{ f [ drop ] }
- { t [ , ] }
+ { t [ check-cookie-string , ] }
[
{
{ [ dup timestamp? ] [ timestamp>cookie-string ] }
{ [ dup duration? ] [ dt>seconds number>string ] }
+ { [ dup real? ] [ number>string ] }
[ ]
} cond
- "=" swap 3append ,
+ check-cookie-string "=" swap check-cookie-string 3append ,
]
} case ;
: unparse-cookie ( cookie -- strings )
[
- dup name>> >lower over value>> (unparse-cookie)
+ dup name>> check-cookie-string >lower
+ over value>> (unparse-cookie)
"path" over path>> (unparse-cookie)
"domain" over domain>> (unparse-cookie)
"expires" over expires>> (unparse-cookie)
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index 9d76c82e4a..83fcf6f4a9 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -82,7 +82,7 @@ TUPLE: file-responder root hook special allow-listings ;
"index.html" append-path dup exists? [ drop f ] unless ;
: serve-directory ( filename -- response )
- request get path>> "/" tail? [
+ request get url>> path>> "/" tail? [
dup
find-index [ serve-file ] [ list-directory ] ?if
] [
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 34bad6db18..13c445b0a8 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -284,6 +284,11 @@ M: revision feed-entry-url id>> revision-url ;
<boilerplate>
{ wiki "page-common" } >>template ;
+: init-sidebar ( -- )
+ "Sidebar" latest-revision [
+ "sidebar" [ from-object ] nest-form
+ ] when* ;
+
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<main-article-action> <article-boilerplate> "" add-responder
@@ -301,5 +306,5 @@ M: revision feed-entry-url id>> revision-url ;
<list-changes-feed-action> "changes.atom" add-responder
<delete-action> "delete" add-responder
<boilerplate>
- [ "sidebar" [ "Sidebar" latest-revision from-object ] nest-form ] >>init
+ [ init-sidebar ] >>init
{ wiki "wiki-common" } >>template ;
From 12b79b287ff23805a089dfe3aca723a1982ebeb5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Jun 2008 05:17:26 -0500
Subject: [PATCH 60/90] Remove unused slot
---
extra/furnace/sessions/sessions.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index bb0a844269..863b8f87cb 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -9,14 +9,13 @@ html.elements
furnace furnace.cache ;
IN: furnace.sessions
-TUPLE: session < server-state uid namespace user-agent client changed? ;
+TUPLE: session < server-state namespace user-agent client changed? ;
: <session> ( id -- session )
session new-server-state ;
session "SESSIONS"
{
- { "uid" "UID" { VARCHAR 255 } }
{ "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
{ "user-agent" "USER_AGENT" TEXT +not-null+ }
{ "client" "CLIENT" TEXT +not-null+ }
From 285c34696f85b8d2840b9399c9ba7801e248a490 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 16 Jun 2008 16:28:49 -0500
Subject: [PATCH 61/90] dns: minor addition
---
extra/dns/dns.factor | 4 ++++
1 file changed, 4 insertions(+)
diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor
index 48380a0d57..214b45ce0c 100644
--- a/extra/dns/dns.factor
+++ b/extra/dns/dns.factor
@@ -424,6 +424,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
}
2cleave message boa ;
+: ba->message ( ba -- message ) parse-message ;
+
+: with-message-bytes ( ba quot -- ) >r ba->message r> call message->ba ; inline
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: send-receive-udp ( ba server -- ba )
From e60f25fe2b01ed56e42a1ae40bcb479cd6423084 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 16 Jun 2008 16:29:11 -0500
Subject: [PATCH 62/90] dns.util: packet abstraction
---
extra/dns/util/util.factor | 13 ++++++++++++-
1 file changed, 12 insertions(+), 1 deletion(-)
diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor
index 5933216a3c..35af74b92a 100644
--- a/extra/dns/util/util.factor
+++ b/extra/dns/util/util.factor
@@ -16,4 +16,15 @@ MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: longer? ( seq seq -- ? ) [ length ] bi@ > ;
\ No newline at end of file
+: longer? ( seq seq -- ? ) [ length ] bi@ > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: io.sockets accessors ;
+
+TUPLE: packet data addr socket ;
+
+: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
+
+: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
+
From aa1708d0b586d29b1500a2ea24f0770b91993119 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 16 Jun 2008 16:29:49 -0500
Subject: [PATCH 63/90] dns.server: new networking code
---
extra/dns/server/server.factor | 38 ++++++++--------------------------
1 file changed, 9 insertions(+), 29 deletions(-)
diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor
index b556780805..3d59f0c3a6 100644
--- a/extra/dns/server/server.factor
+++ b/extra/dns/server/server.factor
@@ -1,6 +1,6 @@
-USING: kernel combinators sequences sets math threads
- io.sockets unicode.case accessors
+USING: kernel combinators sequences sets math threads namespaces continuations
+ debugger io io.sockets unicode.case accessors destructors
combinators.cleave combinators.lib
newfx fry
dns dns.util dns.misc ;
@@ -193,34 +193,14 @@ DEFER: query->rrs
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: (socket) ( -- vec ) V{ f } ;
+: (handle-request) ( packet -- )
+ [ [ find-answer ] with-message-bytes ] change-data respond ;
-: socket ( -- socket ) (socket) 1st ;
+: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
-: init-socket-on-port ( port -- )
- f swap <inet4> <datagram> 0 (socket) as-mutate ;
+: receive-loop ( socket -- )
+ [ receive-packet handle-request ] [ receive-loop ] bi ;
-: init-socket ( -- ) 53 init-socket-on-port ;
+: loop ( addr-spec -- )
+ [ <datagram> '[ , [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (handle-request) ( byte-array addr-spec -- )
- >r
- parse-message
- find-answer
- message->ba
- r>
- socket send ;
-
-: handle-request ( byte-array addr-spec -- )
- '[ , , (handle-request) ] in-thread ;
-
-: loop ( -- ) socket receive handle-request loop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start ( -- ) init-socket loop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: start
From 61fb8a538eb515d12c1b03b8af2a6c5b17fe43e8 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 16 Jun 2008 16:37:52 -0500
Subject: [PATCH 64/90] dns.server: Use a variable for records
---
extra/dns/server/server.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor
index 3d59f0c3a6..04b3ecfbee 100644
--- a/extra/dns/server/server.factor
+++ b/extra/dns/server/server.factor
@@ -9,7 +9,9 @@ IN: dns.server
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: records ( -- vector ) V{ } ;
+SYMBOL: records-var
+
+: records ( -- records ) records-var get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 0a436e1184a2c6e56315ac8efb4e1937d6e4aad4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Jun 2008 00:04:18 -0500
Subject: [PATCH 65/90] New threaded-server
---
extra/io/server/server-docs.factor | 10 --
extra/io/server/server-tests.factor | 7 -
extra/io/server/server.factor | 76 ----------
extra/io/server/summary.txt | 1 -
.../connection}/authors.txt | 0
.../servers/connection/connection-docs.factor | 2 +
.../connection/connection-tests.factor | 47 +++++++
extra/io/servers/connection/connection.factor | 131 ++++++++++++++++++
extra/io/servers/connection/summary.txt | 1 +
.../{server => servers/connection}/tags.txt | 0
extra/io/servers/packet/authors.txt | 1 +
extra/io/servers/packet/datagram.factor | 21 +++
extra/io/servers/packet/summary.txt | 1 +
extra/io/servers/packet/tags.txt | 1 +
extra/io/sockets/secure/secure-tests.factor | 5 +-
extra/io/sockets/secure/secure.factor | 13 +-
extra/io/sockets/sockets-docs.factor | 20 +--
extra/io/sockets/sockets-tests.factor | 2 +-
extra/io/sockets/sockets.factor | 27 ++--
19 files changed, 245 insertions(+), 121 deletions(-)
delete mode 100755 extra/io/server/server-docs.factor
delete mode 100755 extra/io/server/server-tests.factor
delete mode 100755 extra/io/server/server.factor
delete mode 100644 extra/io/server/summary.txt
rename extra/io/{server => servers/connection}/authors.txt (100%)
mode change 100755 => 100644
create mode 100755 extra/io/servers/connection/connection-docs.factor
create mode 100755 extra/io/servers/connection/connection-tests.factor
create mode 100755 extra/io/servers/connection/connection.factor
create mode 100644 extra/io/servers/connection/summary.txt
rename extra/io/{server => servers/connection}/tags.txt (100%)
create mode 100755 extra/io/servers/packet/authors.txt
create mode 100644 extra/io/servers/packet/datagram.factor
create mode 100644 extra/io/servers/packet/summary.txt
create mode 100644 extra/io/servers/packet/tags.txt
diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor
deleted file mode 100755
index 50f38cb146..0000000000
--- a/extra/io/server/server-docs.factor
+++ /dev/null
@@ -1,10 +0,0 @@
-USING: help help.syntax help.markup io ;
-IN: io.server
-
-HELP: with-server
-{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } }
-{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ;
-
-HELP: with-datagrams
-{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } }
-{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ;
diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor
deleted file mode 100755
index 965a70718b..0000000000
--- a/extra/io/server/server-tests.factor
+++ /dev/null
@@ -1,7 +0,0 @@
-IN: io.server.tests
-USING: tools.test io.server io.server.private kernel ;
-
-{ 2 0 } [ [ ] server-loop ] must-infer-as
-{ 3 0 } [ [ ] with-connection ] must-infer-as
-{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
-{ 2 0 } [ [ ] with-datagrams ] must-infer-as
diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor
deleted file mode 100755
index e975880a14..0000000000
--- a/extra/io/server/server.factor
+++ /dev/null
@@ -1,76 +0,0 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io io.sockets io.sockets.secure io.files
-io.streams.duplex logging continuations destructors kernel math
-math.parser namespaces parser sequences strings prettyprint
-debugger quotations calendar threads concurrency.combinators
-assocs fry accessors arrays ;
-IN: io.server
-
-SYMBOL: servers
-
-SYMBOL: remote-address
-
-<PRIVATE
-
-LOG: accepted-connection NOTICE
-
-: with-connection ( client remote local quot -- )
- '[
- , ,
- [ [ remote-address set ] [ local-address set ] bi* ]
- [ 2array accepted-connection ]
- 2bi
- @
- ] with-stream ; inline
-
-: accept-loop ( server quot -- )
- [
- [ [ accept ] [ addr>> ] bi ] dip
- '[ , , , , with-connection ] "Client" spawn drop
- ] 2keep accept-loop ; inline
-
-: server-loop ( addrspec encoding quot -- )
- >r <server> dup servers get push r>
- '[ , accept-loop ] with-disposal ; inline
-
-\ server-loop NOTICE add-error-logging
-
-PRIVATE>
-
-: local-server ( port -- seq )
- "localhost" swap t resolve-host ;
-
-: internet-server ( port -- seq )
- f swap t resolve-host ;
-
-: secure-server ( port -- seq )
- internet-server [ <secure> ] map ;
-
-: with-server ( seq service encoding quot -- )
- V{ } clone servers [
- '[ , [ , , server-loop ] with-logging ] parallel-each
- ] with-variable ; inline
-
-: stop-server ( -- )
- servers get dispose-each ;
-
-<PRIVATE
-
-LOG: received-datagram NOTICE
-
-: datagram-loop ( quot datagram -- )
- [
- [ receive dup received-datagram [ swap call ] dip ] keep
- pick [ send ] [ 3drop ] if
- ] 2keep datagram-loop ; inline
-
-: spawn-datagrams ( quot addrspec -- )
- <datagram> [ datagram-loop ] with-disposal ; inline
-
-\ spawn-datagrams NOTICE add-input-logging
-
-PRIVATE>
-
-: with-datagrams ( seq service quot -- )
- '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
diff --git a/extra/io/server/summary.txt b/extra/io/server/summary.txt
deleted file mode 100644
index e791b704eb..0000000000
--- a/extra/io/server/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-TCP/IP and UDP/IP servers
diff --git a/extra/io/server/authors.txt b/extra/io/servers/connection/authors.txt
old mode 100755
new mode 100644
similarity index 100%
rename from extra/io/server/authors.txt
rename to extra/io/servers/connection/authors.txt
diff --git a/extra/io/servers/connection/connection-docs.factor b/extra/io/servers/connection/connection-docs.factor
new file mode 100755
index 0000000000..b033ec287c
--- /dev/null
+++ b/extra/io/servers/connection/connection-docs.factor
@@ -0,0 +1,2 @@
+USING: help help.syntax help.markup io ;
+IN: io.servers.connection
diff --git a/extra/io/servers/connection/connection-tests.factor b/extra/io/servers/connection/connection-tests.factor
new file mode 100755
index 0000000000..bb87d67917
--- /dev/null
+++ b/extra/io/servers/connection/connection-tests.factor
@@ -0,0 +1,47 @@
+IN: io.servers.connection
+USING: tools.test io.servers.connection io.sockets namespaces
+io.servers.connection.private kernel accessors sequences
+concurrency.promises io.encodings.ascii io threads calendar ;
+
+[ t ] [ <threaded-server> listen-on empty? ] unit-test
+
+[ f ] [
+ <threaded-server>
+ 25 internet-server >>insecure
+ listen-on
+ empty?
+] unit-test
+
+[ t ] [
+ T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 }
+ [ log-connection ] 2keep
+ [ remote-address get = ] [ local-address get = ] bi*
+ and
+] unit-test
+
+[ ] [ <threaded-server> init-server drop ] unit-test
+
+[ 10 ] [
+ <threaded-server>
+ 10 >>max-connections
+ init-server semaphore>> count>>
+] unit-test
+
+[ ] [ <promise> "p" set ] unit-test
+
+[ ] [
+ [
+ <threaded-server>
+ 5 >>max-connections
+ 1237 >>insecure
+ [ "Hello world." write stop-server ] >>handler
+ start-server
+ t "p" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
+
+[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test
diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor
new file mode 100755
index 0000000000..f01112a70f
--- /dev/null
+++ b/extra/io/servers/connection/connection.factor
@@ -0,0 +1,131 @@
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations destructors kernel math math.parser
+namespaces parser sequences strings prettyprint debugger
+quotations combinators combinators.lib logging calendar assocs
+fry accessors arrays io io.sockets io.encodings.ascii
+io.sockets.secure io.files io.streams.duplex io.timeouts
+io.encodings threads concurrency.combinators
+concurrency.semaphores ;
+IN: io.servers.connection
+
+TUPLE: threaded-server
+name
+secure insecure
+secure-config
+sockets
+max-connections
+semaphore
+timeout
+encoding
+handler ;
+
+: local-server ( port -- addrspec ) "localhost" swap <inet> ;
+
+: internet-server ( port -- addrspec ) f swap <inet> ;
+
+: new-threaded-server ( class -- threaded-server )
+ new
+ "server" >>name
+ ascii >>encoding
+ 1 minutes >>timeout
+ V{ } clone >>sockets
+ <secure-config> >>secure-config
+ [ "No handler quotation" throw ] >>handler ; inline
+
+: <threaded-server> ( -- threaded-server )
+ threaded-server new-threaded-server ;
+
+SYMBOL: remote-address
+
+GENERIC: handle-client* ( server -- )
+
+<PRIVATE
+
+: >insecure ( addrspec -- addrspec' )
+ dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
+
+: >secure ( addrspec -- addrspec' )
+ >insecure
+ dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
+
+: listen-on ( threaded-server -- addrspecs )
+ [ secure>> >secure ] [ insecure>> >insecure ] bi
+ [ resolve-host ] bi@ append ;
+
+LOG: accepted-connection NOTICE
+
+: log-connection ( remote local -- )
+ [ [ remote-address set ] [ local-address set ] bi* ]
+ [ 2array accepted-connection ]
+ 2bi ;
+
+M: threaded-server handle-client* handler>> call ;
+
+: handle-client ( client remote local -- )
+ '[
+ , , log-connection
+ threaded-server get
+ [ timeout>> timeouts ] [ handle-client* ] bi
+ ] with-stream ;
+
+: thread-name ( server-name addrspec -- string )
+ unparse " connection from " swap 3append ;
+
+: accept-connection ( server -- )
+ [ accept ] [ addr>> ] bi
+ [ '[ , , , handle-client ] ]
+ [ drop threaded-server get name>> swap thread-name ] 2bi
+ spawn drop ;
+
+: accept-loop ( server -- )
+ [
+ threaded-server get semaphore>>
+ [ [ accept-connection ] with-semaphore ]
+ [ accept-connection ]
+ if*
+ ] [ accept-loop ] bi ; inline
+
+\ accept-loop ERROR add-error-logging
+
+: start-accept-loop ( server -- )
+ threaded-server get encoding>> <server>
+ [ threaded-server get sockets>> push ]
+ [ [ accept-loop ] with-disposal ]
+ bi ;
+
+: init-server ( threaded-server -- threaded-server )
+ dup semaphore>> [
+ dup max-connections>> [
+ <semaphore> >>semaphore
+ ] when*
+ ] unless ;
+
+PRIVATE>
+
+: start-server ( threaded-server -- )
+ init-server
+ dup secure-config>> [
+ dup threaded-server [
+ dup name>> [
+ listen-on [
+ start-accept-loop
+ ] parallel-each
+ ] with-logging
+ ] with-variable
+ ] with-secure-context ;
+
+: stop-server ( -- )
+ threaded-server get [ f ] change-sockets drop dispose-each ;
+
+GENERIC: port ( addrspec -- n )
+
+M: integer port ;
+
+M: object port port>> ;
+
+: secure-port ( -- n )
+ threaded-server get dup [ secure>> port ] when ;
+
+: insecure-port ( -- n )
+ threaded-server get dup [ insecure>> port ] when ;
diff --git a/extra/io/servers/connection/summary.txt b/extra/io/servers/connection/summary.txt
new file mode 100644
index 0000000000..8269ecfc38
--- /dev/null
+++ b/extra/io/servers/connection/summary.txt
@@ -0,0 +1 @@
+Multi-threaded TCP/IP servers
diff --git a/extra/io/server/tags.txt b/extra/io/servers/connection/tags.txt
similarity index 100%
rename from extra/io/server/tags.txt
rename to extra/io/servers/connection/tags.txt
diff --git a/extra/io/servers/packet/authors.txt b/extra/io/servers/packet/authors.txt
new file mode 100755
index 0000000000..1901f27a24
--- /dev/null
+++ b/extra/io/servers/packet/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/extra/io/servers/packet/datagram.factor b/extra/io/servers/packet/datagram.factor
new file mode 100644
index 0000000000..03596ee43c
--- /dev/null
+++ b/extra/io/servers/packet/datagram.factor
@@ -0,0 +1,21 @@
+IN: io.servers.datagram
+
+<PRIVATE
+
+LOG: received-datagram NOTICE
+
+: datagram-loop ( quot datagram -- )
+ [
+ [ receive dup received-datagram [ swap call ] dip ] keep
+ pick [ send ] [ 3drop ] if
+ ] 2keep datagram-loop ; inline
+
+: spawn-datagrams ( quot addrspec -- )
+ <datagram> [ datagram-loop ] with-disposal ; inline
+
+\ spawn-datagrams NOTICE add-input-logging
+
+PRIVATE>
+
+: with-datagrams ( seq service quot -- )
+ '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
diff --git a/extra/io/servers/packet/summary.txt b/extra/io/servers/packet/summary.txt
new file mode 100644
index 0000000000..29247a2937
--- /dev/null
+++ b/extra/io/servers/packet/summary.txt
@@ -0,0 +1 @@
+Multi-threaded UDP/IP servers
diff --git a/extra/io/servers/packet/tags.txt b/extra/io/servers/packet/tags.txt
new file mode 100644
index 0000000000..992ae12982
--- /dev/null
+++ b/extra/io/servers/packet/tags.txt
@@ -0,0 +1 @@
+network
diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor
index 9b9436a8db..75ac39e190 100644
--- a/extra/io/sockets/secure/secure-tests.factor
+++ b/extra/io/sockets/secure/secure-tests.factor
@@ -1 +1,4 @@
-! No unit tests here, until Windows SSL is implemented
+IN: io.sockets.secure.tests
+USING: io.sockets.secure tools.test ;
+
+[ "hello" 24 ] [ "hello" 24 <inet> <secure> [ host>> ] [ port>> ] bi ] unit-test
diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor
index 448a5cdda0..10aec22ee5 100644
--- a/extra/io/sockets/secure/secure.factor
+++ b/extra/io/sockets/secure/secure.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
-destructors io.sockets sequences inspector calendar ;
+destructors io.sockets sequences inspector calendar delegate ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
@@ -42,8 +42,10 @@ TUPLE: secure addrspec ;
C: <secure> secure
-: resolve-secure-host ( host port passive? -- seq )
- resolve-host [ <secure> ] map ;
+CONSULT: inet secure addrspec>> ;
+
+M: secure resolve-host ( secure -- seq )
+ addrspec>> resolve-host [ <secure> ] map ;
HOOK: check-certificate secure-socket-backend ( host handle -- )
@@ -53,9 +55,8 @@ PREDICATE: secure-inet < secure addrspec>> inet? ;
M: secure-inet (client)
[
- addrspec>>
- [ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
- host>> pick handle>> check-certificate
+ [ resolve-host (client) [ |dispose ] dip ] keep
+ addrspec>> host>> pick handle>> check-certificate
] with-destructors ;
PRIVATE>
diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor
index 78cddd5d3b..6aa46ccdbc 100755
--- a/extra/io/sockets/sockets-docs.factor
+++ b/extra/io/sockets/sockets-docs.factor
@@ -27,7 +27,7 @@ $nl
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
{ { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" }
}
-"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
+"The " { $vocab-link "io.servers.connection" } " library defines high-level wrappers around " { $link <server> } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
{ $see-also "io.sockets.secure" } ;
ARTICLE: "network-packet" "Packet-oriented networking"
@@ -79,7 +79,7 @@ HELP: inet
HELP: inet4
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
{ $notes
-"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
+"Most applications do not operate on IPv4 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
}
{ $examples
{ $code "\"127.0.0.1\" 8080 <inet4>" }
@@ -88,7 +88,7 @@ HELP: inet4
HELP: inet6
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
{ $notes
-"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
+"Most applications do not operate on IPv6 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name." }
{ $examples
{ $code "\"::1\" 8080 <inet6>" }
} ;
@@ -118,10 +118,10 @@ HELP: <server>
}
{ $notes
"To start a TCP/IP server which listens for connections from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "f 1234 t resolve-host" }
+ { $code "f 1234 <inet> resolve-host" }
"To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "\"localhost\" 1234 t resolve-host" }
- "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this."
+ { $code "\"localhost\" 1234 <inet> resolve-host" }
+ "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this."
$nl
"To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:"
{ $unchecked-example
@@ -148,9 +148,9 @@ HELP: <datagram>
}
{ $notes
"To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "f 1234 t resolve-host" }
+ { $code "f 1234 <inet> resolve-host" }
"To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "\"localhost\" 1234 t resolve-host" }
+ { $code "\"localhost\" 1234 <inet> resolve-host" }
"Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly."
"Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding"
}
@@ -165,3 +165,7 @@ HELP: send
{ $values { "packet" byte-array } { "addrspec" "an address specifier" } { "datagram" "a datagram socket" } }
{ $description "Sends a packet to the given address." }
{ $errors "Throws an error if the packet could not be sent." } ;
+
+HELP: resolve-host
+{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
+{ $description "Resolves host names to IP addresses." } ;
diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor
index 8264bec032..4b95a31512 100755
--- a/extra/io/sockets/sockets-tests.factor
+++ b/extra/io/sockets/sockets-tests.factor
@@ -45,7 +45,7 @@ concurrency.promises threads io.streams.string ;
[ "1:2:0:0:0:0:3:4" ]
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
-[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
+[ t ] [ "localhost" 80 <inet> resolve-host length 1 >= ] unit-test
! Smoke-test UDP
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test
diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor
index 4efd30c65e..a9278c8357 100755
--- a/extra/io/sockets/sockets.factor
+++ b/extra/io/sockets/sockets.factor
@@ -259,20 +259,26 @@ HOOK: (send) io-backend ( packet addrspec datagram -- )
[ addrinfo>addrspec ] map
sift ;
-: prepare-resolve-host ( host serv passive? -- host' serv' flags )
+: prepare-resolve-host ( addrspec -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
#! change it later. This is a workaround for a FreeBSD
#! getaddrinfo() limitation -- on Windows, Linux and Mac,
#! we can convert a number to a string and pass that as the
#! service name, but on FreeBSD this gives us an unknown
#! service error.
- >r
- dup integer? [ port-override set "http" ] when
- r> AI_PASSIVE 0 ? ;
+ [ host>> ]
+ [ port>> dup integer? [ port-override set "http" ] when ] bi
+ over 0 AI_PASSIVE ? ;
HOOK: addrinfo-error io-backend ( n -- )
-: resolve-host ( host serv passive? -- seq )
+GENERIC: resolve-host ( addrspec -- seq )
+
+TUPLE: inet host port ;
+
+C: <inet> inet
+
+M: inet resolve-host
[
prepare-resolve-host
"addrinfo" <c-object>
@@ -284,17 +290,16 @@ HOOK: addrinfo-error io-backend ( n -- )
freeaddrinfo
] with-scope ;
+M: f resolve-host drop { } ;
+
+M: object resolve-host 1array ;
+
: host-name ( -- string )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
ascii alien>string ;
-TUPLE: inet host port ;
-
-C: <inet> inet
-
-M: inet (client)
- [ host>> ] [ port>> ] bi f resolve-host (client) ;
+M: inet (client) resolve-host (client) ;
ERROR: invalid-inet-server addrspec ;
From 24e9149a2e9528e5b1f8b1952953b5e3cfe05331 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Jun 2008 00:08:50 -0500
Subject: [PATCH 66/90] Updating code for new io.servers code
---
.../distributed/distributed.factor | 21 +++++++++----------
extra/eval-server/authors.txt | 1 -
extra/eval-server/eval-server.factor | 11 ----------
extra/eval-server/summary.txt | 1 -
extra/eval-server/tags.txt | 4 ----
extra/smtp/server/server.factor | 2 +-
extra/tty-server/tty-server.factor | 16 +++++++-------
7 files changed, 20 insertions(+), 36 deletions(-)
delete mode 100644 extra/eval-server/authors.txt
delete mode 100644 extra/eval-server/eval-server.factor
delete mode 100644 extra/eval-server/summary.txt
delete mode 100644 extra/eval-server/tags.txt
diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor
index c637f4baa3..c9257eb27e 100755
--- a/extra/concurrency/distributed/distributed.factor
+++ b/extra/concurrency/distributed/distributed.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: serialize sequences concurrency.messaging threads io
-io.server qualified arrays namespaces kernel io.encodings.binary
-accessors ;
+io.servers.connection io.encodings.binary
+qualified arrays namespaces kernel accessors ;
FROM: io.sockets => host-name <inet> with-client ;
IN: concurrency.distributed
@@ -10,21 +10,20 @@ SYMBOL: local-node
: handle-node-client ( -- )
deserialize
- [ first2 get-process send ]
- [ stop-server ] if* ;
+ [ first2 get-process send ] [ stop-server ] if* ;
-: (start-node) ( addrspecs addrspec -- )
+: (start-node) ( addrspec addrspec -- )
local-node set-global
[
- "concurrency.distributed"
- binary
- [ handle-node-client ] with-server
+ <threaded-server>
+ swap >>insecure
+ binary >>encoding
+ "concurrency.distributed" >>name
+ [ handle-node-client ] >>handler
] curry "Distributed concurrency server" spawn drop ;
: start-node ( port -- )
- [ internet-server ]
- [ host-name swap <inet> ] bi
- (start-node) ;
+ host-name over <inet> (start-node) ;
TUPLE: remote-process id node ;
diff --git a/extra/eval-server/authors.txt b/extra/eval-server/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/extra/eval-server/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/eval-server/eval-server.factor b/extra/eval-server/eval-server.factor
deleted file mode 100644
index 3bfae616a2..0000000000
--- a/extra/eval-server/eval-server.factor
+++ /dev/null
@@ -1,11 +0,0 @@
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: listener io.server strings parser byte-arrays ;
-IN: eval-server
-
-: eval-server ( -- )
- 9998 local-server "eval-server" [
- >string eval>string >byte-array
- ] with-datagrams ;
-
-MAIN: eval-server
diff --git a/extra/eval-server/summary.txt b/extra/eval-server/summary.txt
deleted file mode 100644
index b75930ac9f..0000000000
--- a/extra/eval-server/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Listens for UDP packets on localhost:9998, evaluates them and sends back result
diff --git a/extra/eval-server/tags.txt b/extra/eval-server/tags.txt
deleted file mode 100644
index f628c95985..0000000000
--- a/extra/eval-server/tags.txt
+++ /dev/null
@@ -1,4 +0,0 @@
-demos
-network
-tools
-applications
diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor
index 824651030d..a6a8bb2cca 100755
--- a/extra/smtp/server/server.factor
+++ b/extra/smtp/server/server.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Elie CHAFTARI
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel prettyprint io io.timeouts io.server
+USING: combinators kernel prettyprint io io.timeouts
sequences namespaces io.sockets continuations calendar
io.encodings.ascii io.streams.duplex destructors ;
IN: smtp.server
diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor
index d4b1a34e76..e155c2068d 100644
--- a/extra/tty-server/tty-server.factor
+++ b/extra/tty-server/tty-server.factor
@@ -1,11 +1,13 @@
-USING: listener io.server io.encodings.utf8 ;
+USING: listener io.servers.connection io.encodings.utf8 ;
IN: tty-server
-: tty-server ( port -- )
- local-server
- "tty-server"
- utf8 [ listener ] with-server ;
+: <tty-server> ( port -- )
+ <threaded-server>
+ "tty-server" >>name
+ utf8 >>encoding
+ swap local-server >>insecure
+ [ listener ] >>handler ;
-: default-tty-server ( -- ) 9999 tty-server ;
+: tty-server ( -- ) 9999 tty-server ;
-MAIN: default-tty-server
+MAIN: tty-server
From dc7b414f5718423d1f6d91109fa11c26c4cf7e47 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Jun 2008 00:10:09 -0500
Subject: [PATCH 67/90] More flexible io.streams.limited, works with encoded
streams
---
extra/io/streams/limited/limited-tests.factor | 8 ++++++++
extra/io/streams/limited/limited.factor | 13 +++++++++----
2 files changed, 17 insertions(+), 4 deletions(-)
diff --git a/extra/io/streams/limited/limited-tests.factor b/extra/io/streams/limited/limited-tests.factor
index d160a3f756..eb5b921260 100644
--- a/extra/io/streams/limited/limited-tests.factor
+++ b/extra/io/streams/limited/limited-tests.factor
@@ -30,3 +30,11 @@ namespaces tools.test strings kernel ;
[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
+
+[ "he" CHAR: l ] [
+ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
+ ascii <byte-reader> [
+ 5 limit-input
+ "l" read-until
+ ] with-input-stream
+] unit-test
diff --git a/extra/io/streams/limited/limited.factor b/extra/io/streams/limited/limited.factor
index 669240d28b..e89b31a884 100644
--- a/extra/io/streams/limited/limited.factor
+++ b/extra/io/streams/limited/limited.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math io destructors accessors sequences
-namespaces ;
+USING: kernel math io io.encodings destructors accessors
+sequences namespaces ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit ;
@@ -12,8 +12,13 @@ TUPLE: limited-stream stream count limit ;
swap >>stream
0 >>count ;
-: limit-input ( limit -- )
- input-stream [ swap <limited-stream> ] change ;
+GENERIC# limit 1 ( stream limit -- stream' )
+
+M: decoder limit [ clone ] dip [ limit ] curry change-stream ;
+
+M: object limit <limited-stream> ;
+
+: limit-input ( limit -- ) input-stream [ swap limit ] change ;
ERROR: limit-exceeded ;
From 5809df329a6f351d187eadd59b2abfbf5196ae5e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Jun 2008 00:10:18 -0500
Subject: [PATCH 68/90] Add a unit test
---
extra/io/unix/sockets/secure/secure-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor
index dca8fbbbc7..dee5c32349 100644
--- a/extra/io/unix/sockets/secure/secure-tests.factor
+++ b/extra/io/unix/sockets/secure/secure-tests.factor
@@ -14,7 +14,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >>password
- swap with-secure-context ;
+ swap with-secure-context ; inline
:: server-test ( quot -- )
[
From cc605060b20d0928c0e9b803b1ab154b6ef33e1b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Jun 2008 00:10:46 -0500
Subject: [PATCH 69/90] Working on https server support
---
extra/furnace/asides/asides.factor | 2 +-
.../recover-password/recover-password.factor | 3 +-
.../features/registration/registration.factor | 3 +-
extra/furnace/auth/login/login.factor | 3 +-
extra/furnace/flash/flash.factor | 2 +-
extra/furnace/furnace.factor | 7 --
extra/furnace/redirection/redirection.factor | 29 ++++++
extra/furnace/sessions/sessions-tests.factor | 2 +-
extra/furnace/sessions/sessions.factor | 7 +-
extra/http/http-tests.factor | 2 +-
extra/http/server/server.factor | 32 +++----
extra/webapps/blogs/blogs.factor | 1 +
extra/webapps/pastebin/pastebin.factor | 1 +
extra/webapps/planet/planet.factor | 1 +
extra/webapps/todo/todo.factor | 1 +
extra/webapps/user-admin/user-admin.factor | 1 +
extra/webapps/wee-url/wee-url.factor | 2 +-
extra/webapps/wiki/wiki.factor | 1 +
.../concatenative/concatenative.factor | 88 +++++++++++++++++++
extra/websites/concatenative/page.css | 78 ++++++++++++++++
extra/websites/concatenative/page.xml | 28 ++++++
21 files changed, 257 insertions(+), 37 deletions(-)
create mode 100644 extra/furnace/redirection/redirection.factor
create mode 100644 extra/websites/concatenative/concatenative.factor
create mode 100644 extra/websites/concatenative/page.css
create mode 100644 extra/websites/concatenative/page.xml
diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor
index 15d1c1df0b..9f1411188c 100644
--- a/extra/furnace/asides/asides.factor
+++ b/extra/furnace/asides/asides.factor
@@ -4,7 +4,7 @@ USING: accessors namespaces sequences arrays kernel
assocs assocs.lib hashtables math.parser urls combinators
html.elements html.templates.chloe.syntax db.types db.tuples
http http.server http.server.filters
-furnace furnace.cache furnace.sessions ;
+furnace furnace.cache furnace.sessions furnace.redirection ;
IN: furnace.asides
TUPLE: aside < server-state session method url post-data ;
diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor
index 1e8d163e99..806df024f0 100644
--- a/extra/furnace/auth/features/recover-password/recover-password.factor
+++ b/extra/furnace/auth/features/recover-password/recover-password.factor
@@ -3,7 +3,8 @@
USING: namespaces accessors kernel assocs arrays io.sockets threads
fry urls smtp validators html.forms
http http.server.responses http.server.dispatchers
-furnace furnace.actions furnace.auth furnace.auth.providers ;
+furnace furnace.actions furnace.auth furnace.auth.providers
+furnace.redirection ;
IN: furnace.auth.features.recover-password
SYMBOL: lost-password-from
diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor
index 2bc7688b10..5c1851fb64 100644
--- a/extra/furnace/auth/features/registration/registration.factor
+++ b/extra/furnace/auth/features/registration/registration.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces validators html.forms urls
http.server.dispatchers
-furnace furnace.auth furnace.auth.providers furnace.actions ;
+furnace furnace.auth furnace.auth.providers furnace.actions
+furnace.redirection ;
IN: furnace.auth.features.registration
: <register-action> ( -- action )
diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index e2b208de3a..4c53cb9c89 100755
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -10,6 +10,7 @@ furnace.asides
furnace.actions
furnace.sessions
furnace.utilities
+furnace.redirection
furnace.auth.login.permits ;
IN: furnace.auth.login
@@ -94,7 +95,7 @@ M: login-realm login-required*
begin-aside
protected get description>> description set
protected get capabilities>> capabilities set
- URL" $realm/login" flashed-variables <flash-redirect> ;
+ URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;
: <login-realm> ( responder name -- auth )
login-realm new-realm
diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor
index e06cdac090..2149e4fcd7 100644
--- a/extra/furnace/flash/flash.factor
+++ b/extra/furnace/flash/flash.factor
@@ -3,7 +3,7 @@
USING: namespaces assocs assocs.lib kernel sequences accessors
urls db.types db.tuples math.parser fry
http http.server http.server.filters http.server.redirection
-furnace furnace.cache furnace.sessions ;
+furnace furnace.cache furnace.sessions furnace.redirection ;
IN: furnace.flash
TUPLE: flash-scope < server-state session namespace ;
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 521f8a3bc1..90b529e385 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -63,13 +63,6 @@ M: url adjust-url
M: string adjust-url ;
-: <redirect> ( url -- response )
- adjust-url request get method>> {
- { "GET" [ <temporary-redirect> ] }
- { "HEAD" [ <temporary-redirect> ] }
- { "POST" [ <permanent-redirect> ] }
- } case ;
-
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
diff --git a/extra/furnace/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor
new file mode 100644
index 0000000000..7f87c677b9
--- /dev/null
+++ b/extra/furnace/redirection/redirection.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators namespaces
+io.servers.connection
+http http.server http.server.redirection
+furnace ;
+IN: furnace.redirection
+
+: <redirect> ( url -- response )
+ adjust-url request get method>> {
+ { "GET" [ <temporary-redirect> ] }
+ { "HEAD" [ <temporary-redirect> ] }
+ { "POST" [ <permanent-redirect> ] }
+ } case ;
+
+: >secure-url ( url -- url' )
+ clone
+ "https" >>protocol
+ secure-port >>port ;
+
+: <secure-redirect> ( url -- response )
+ >secure-url <redirect> ;
+
+TUPLE: redirect-responder to ;
+
+: <redirect-responder> ( url -- responder )
+ redirect-responder boa ;
+
+M: redirect-responder call-responder* nip to>> <redirect> ;
diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor
index a97ba091c0..98d1bbdfc9 100755
--- a/extra/furnace/sessions/sessions-tests.factor
+++ b/extra/furnace/sessions/sessions-tests.factor
@@ -1,7 +1,7 @@
IN: furnace.sessions.tests
USING: tools.test http furnace.sessions
furnace.actions http.server http.server.responses
-math namespaces kernel accessors io.sockets io.server
+math namespaces kernel accessors io.sockets io.servers.connection
prettyprint io.streams.string io.files splitting destructors
sequences db db.tuples db.sqlite continuations urls math.parser
furnace ;
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index 863b8f87cb..6e50417ea1 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -1,8 +1,9 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.intervals math.parser namespaces
-random accessors quotations hashtables sequences continuations
-fry calendar combinators combinators.lib destructors alarms io.server
+strings random accessors quotations hashtables sequences continuations
+fry calendar combinators combinators.lib destructors alarms
+io.servers.connection
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
@@ -109,7 +110,7 @@ M: session-saver dispose
: request-session ( -- session/f )
session-id-key
- client-state dup [ string>number ] when
+ client-state dup string? [ string>number ] when
get-session verify-session ;
: <session-cookie> ( -- cookie )
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 73d26aa327..b5ed144579 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -123,7 +123,7 @@ read-response-test-1' 1array [
! Live-fire exercise
USING: http.server http.server.static furnace.sessions furnace.alloy
furnace.actions furnace.auth furnace.auth.login furnace.db http.client
-io.server io.files io io.encodings.ascii
+io.servers.connection io.files io io.encodings.ascii
accessors namespaces threads
http.server.responses http.server.redirection
http.server.dispatchers db.tuples ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index f709939e21..0312e62e8d 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -4,7 +4,6 @@ USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
combinators tools.vocabs tools.time math
io
-io.server
io.sockets
io.sockets.secure
io.encodings
@@ -12,6 +11,7 @@ io.encodings.utf8
io.encodings.ascii
io.encodings.binary
io.streams.limited
+io.servers.connection
io.timeouts
fry logging logging.insomniac calendar urls
http
@@ -118,10 +118,6 @@ LOG: httpd-header NOTICE
: ?refresh-all ( -- )
development? get-global [ global [ refresh-all ] bind ] when ;
-: setup-limits ( -- )
- 1 minutes timeouts
- 64 1024 * limit-input ;
-
LOG: httpd-benchmark DEBUG
: ?benchmark ( quot -- )
@@ -130,25 +126,23 @@ LOG: httpd-benchmark DEBUG
httpd-benchmark
] [ call ] if ; inline
-: handle-client ( -- )
+TUPLE: http-server < threaded-server ;
+
+M: http-server handle-client*
+ drop
[
- setup-limits
- ascii decode-input
- ascii encode-output
+ 64 1024 * limit-input
?refresh-all
read-request
[ do-request ] ?benchmark
[ do-response ] ?benchmark
] with-destructors ;
-: httpd ( port -- )
- dup integer? [ internet-server ] when
- "http.server" binary [ handle-client ] with-server ;
+: <http-server> ( -- server )
+ http-server new-threaded-server
+ "http.server" >>name
+ "http" protocol-port >>insecure
+ "https" protocol-port >>secure ;
-: httpd-main ( -- )
- 8888 httpd ;
-
-: httpd-insomniac ( -- )
- "http.server" { httpd-hit } schedule-insomniac ;
-
-MAIN: httpd-main
+: http-insomniac ( -- )
+ "http.server" { "httpd-hit" } schedule-insomniac ;
diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor
index aa1aa5edc7..10e0ab54c0 100644
--- a/extra/webapps/blogs/blogs.factor
+++ b/extra/webapps/blogs/blogs.factor
@@ -7,6 +7,7 @@ html.components
http.server.dispatchers
furnace
furnace.actions
+furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index 251872d1ac..3aeb21420f 100644
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -12,6 +12,7 @@ http.server.dispatchers
http.server.redirection
furnace
furnace.actions
+furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index b472881e73..ca74b7e642 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -10,6 +10,7 @@ http.server
http.server.dispatchers
furnace
furnace.actions
+furnace.redirection
furnace.boilerplate
furnace.auth.login
furnace.auth
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 4b1b59e80f..0fb7e7dc89 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -11,6 +11,7 @@ furnace
furnace.boilerplate
furnace.auth
furnace.actions
+furnace.redirection
furnace.db
furnace.auth.login ;
IN: webapps.todo
diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor
index 8c7b1b21c9..359730d4b2 100644
--- a/extra/webapps/user-admin/user-admin.factor
+++ b/extra/webapps/user-admin/user-admin.factor
@@ -12,6 +12,7 @@ furnace.auth.providers.db
furnace.auth.login
furnace.auth
furnace.actions
+furnace.redirection
furnace.utilities
http.server
http.server.dispatchers ;
diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor
index 2396e98b2a..27187c4352 100644
--- a/extra/webapps/wee-url/wee-url.factor
+++ b/extra/webapps/wee-url/wee-url.factor
@@ -4,7 +4,7 @@
USING: math.ranges sequences random accessors combinators.lib
kernel namespaces fry db.types db.tuples urls validators
html.components html.forms http http.server.dispatchers furnace
-furnace.actions furnace.boilerplate ;
+furnace.actions furnace.boilerplate furnace.redirection ;
IN: webapps.wee-url
TUPLE: wee-url < dispatcher ;
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 13c445b0a8..77ee242668 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -8,6 +8,7 @@ http.server
http.server.dispatchers
furnace
furnace.actions
+furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate
diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor
new file mode 100644
index 0000000000..fcf98b08da
--- /dev/null
+++ b/extra/websites/concatenative/concatenative.factor
@@ -0,0 +1,88 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+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
+http.server
+http.server.dispatchers
+http.server.redirection
+furnace.alloy
+furnace.auth.login
+furnace.auth.providers.db
+furnace.auth.features.edit-profile
+furnace.auth.features.recover-password
+furnace.auth.features.registration
+furnace.boilerplate
+furnace.redirection
+webapps.blogs
+webapps.pastebin
+webapps.planet
+webapps.todo
+webapps.wiki
+webapps.wee-url
+webapps.user-admin ;
+IN: websites.concatenative
+
+: test-db ( -- db params ) "resource:test.db" sqlite-db ;
+
+: init-factor-db ( -- )
+ test-db [
+ init-furnace-tables
+
+ {
+ post comment
+ paste annotation
+ blog posting
+ todo
+ short-url
+ article revision
+ } ensure-tables
+ ] with-db ;
+
+TUPLE: factor-website < dispatcher ;
+
+: <factor-website> ( -- responder )
+ factor-website new-dispatcher
+ <blogs> "blogs" add-responder
+ <todo-list> "todo" add-responder
+ <pastebin> "pastebin" add-responder
+ <planet-factor> "planet" add-responder
+ <wiki> "wiki" add-responder
+ <wee-url> "wee-url" add-responder
+ <user-admin> "user-admin" add-responder
+ URL" /wiki/view/Front Page" <redirect-responder> "" add-responder
+ "Factor website" <login-realm>
+ "Factor website" >>name
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ <boilerplate>
+ { factor-website "page" } >>template
+ test-db <alloy> ;
+
+: init-factor-website ( -- )
+ "factorcode.org" 25 <inet> smtp-server set-global
+ "todo@factorcode.org" lost-password-from set-global
+ "website@factorcode.org" insomniac-sender set-global
+ "slava@factorcode.org" insomniac-recipients set-global
+ init-factor-db
+ <factor-website> main-responder set-global ;
+
+: <factor-secure-config> ( -- config )
+ <secure-config>
+ "resource:extra/openssl/test/server.pem" >>key-file
+ "resource:extra/openssl/test/dh1024.pem" >>dh-file
+ "password" >>password ;
+
+: <factor-website-server> ( -- threaded-server )
+ <http-server>
+ <factor-secure-config> >>secure-config
+ 8080 >>insecure
+ 8431 >>secure ;
+
+: start-factor-website ( -- )
+ test-db start-expiring
+ test-db start-update-task
+ http-insomniac
+ <factor-website-server> start-server ;
diff --git a/extra/websites/concatenative/page.css b/extra/websites/concatenative/page.css
new file mode 100644
index 0000000000..49e26883ad
--- /dev/null
+++ b/extra/websites/concatenative/page.css
@@ -0,0 +1,78 @@
+body, button {
+ font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#444;
+}
+
+.link-button {
+ padding: 0px;
+ background: none;
+ border: none;
+}
+
+a, .link {
+ color: #222;
+ border-bottom:1px dotted #666;
+ text-decoration:none;
+}
+
+a:hover, .link:hover {
+ border-bottom:1px solid #66a;
+}
+
+.error { color: #a00; }
+
+.errors li { color: #a00; }
+
+.field-label {
+ text-align: right;
+}
+
+.inline {
+ display: inline;
+}
+
+.navbar {
+ background-color: #eee;
+ padding: 5px;
+ border: 1px solid #ccc;
+}
+
+.big-field-label {
+ vertical-align: top;
+}
+
+.description {
+ padding: 5px;
+ color: #000;
+}
+
+.description pre {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+}
+
+.description p:first-child {
+ margin-top: 0px;
+}
+
+.description p:last-child {
+ margin-bottom: 0px;
+}
+
+.description table, .description td {
+ border-color: #666;
+ border-style: solid;
+}
+
+.description table {
+ border-width: 0 0 1px 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+.description td {
+ margin: 0;
+ padding: 4px;
+ border-width: 1px 1px 0 0;
+}
+
diff --git a/extra/websites/concatenative/page.xml b/extra/websites/concatenative/page.xml
new file mode 100644
index 0000000000..464a3d9c5d
--- /dev/null
+++ b/extra/websites/concatenative/page.xml
@@ -0,0 +1,28 @@
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+ <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <head>
+ <t:write-title />
+
+ <t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
+
+ <t:style t:include="resource:extra/websites/concatenative/page.css" />
+
+ <t:write-style />
+
+ <t:write-atom />
+ </head>
+
+ <body>
+ <t:call-next-template />
+ </body>
+
+ </t:chloe>
+
+</html>
From 44112e32e6d66429a0a344f56efd520b5bf5b177 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Jun 2008 05:21:45 -0500
Subject: [PATCH 70/90] Fix build errors
---
.../distributed/distributed-tests.factor | 10 ++-
.../distributed/distributed.factor | 1 +
extra/io/servers/connection/connection.factor | 4 +-
extra/io/sockets/secure/secure-tests.factor | 2 +-
extra/tty-server/tty-server.factor | 8 +-
extra/webapps/counter/counter.factor | 2 +-
.../factor-website/factor-website.factor | 73 -----------------
extra/webapps/factor-website/page.css | 78 -------------------
extra/webapps/factor-website/page.xml | 28 -------
9 files changed, 16 insertions(+), 190 deletions(-)
delete mode 100644 extra/webapps/factor-website/factor-website.factor
delete mode 100644 extra/webapps/factor-website/page.css
delete mode 100644 extra/webapps/factor-website/page.xml
diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor
index ca1da0deaa..dc20e7ad5c 100755
--- a/extra/concurrency/distributed/distributed-tests.factor
+++ b/extra/concurrency/distributed/distributed-tests.factor
@@ -1,9 +1,9 @@
IN: concurrency.distributed.tests
USING: tools.test concurrency.distributed kernel io.files
arrays io.sockets system combinators threads math sequences
-concurrency.messaging continuations ;
+concurrency.messaging continuations accessors prettyprint ;
-: test-node
+: test-node ( -- addrspec )
{
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
{ [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
@@ -11,9 +11,9 @@ concurrency.messaging continuations ;
[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
-[ ] [ test-node dup 1array swap (start-node) ] unit-test
+[ ] [ test-node dup (start-node) ] unit-test
-[ ] [ 100 sleep ] unit-test
+[ ] [ 1000 sleep ] unit-test
[ ] [
[
@@ -30,4 +30,6 @@ concurrency.messaging continuations ;
receive
] unit-test
+[ ] [ 1000 sleep ] unit-test
+
[ ] [ test-node stop-node ] unit-test
diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor
index c9257eb27e..9ae2627505 100755
--- a/extra/concurrency/distributed/distributed.factor
+++ b/extra/concurrency/distributed/distributed.factor
@@ -20,6 +20,7 @@ SYMBOL: local-node
binary >>encoding
"concurrency.distributed" >>name
[ handle-node-client ] >>handler
+ start-server
] curry "Distributed concurrency server" spawn drop ;
: start-node ( port -- )
diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor
index f01112a70f..b062322142 100755
--- a/extra/io/servers/connection/connection.factor
+++ b/extra/io/servers/connection/connection.factor
@@ -86,14 +86,14 @@ M: threaded-server handle-client* handler>> call ;
if*
] [ accept-loop ] bi ; inline
-\ accept-loop ERROR add-error-logging
-
: start-accept-loop ( server -- )
threaded-server get encoding>> <server>
[ threaded-server get sockets>> push ]
[ [ accept-loop ] with-disposal ]
bi ;
+\ start-accept-loop ERROR add-error-logging
+
: init-server ( threaded-server -- threaded-server )
dup semaphore>> [
dup max-connections>> [
diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor
index 75ac39e190..78de43d379 100644
--- a/extra/io/sockets/secure/secure-tests.factor
+++ b/extra/io/sockets/secure/secure-tests.factor
@@ -1,4 +1,4 @@
IN: io.sockets.secure.tests
-USING: io.sockets.secure tools.test ;
+USING: accessors kernel io.sockets io.sockets.secure tools.test ;
[ "hello" 24 ] [ "hello" 24 <inet> <secure> [ host>> ] [ port>> ] bi ] unit-test
diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor
index e155c2068d..4ba38ad06a 100644
--- a/extra/tty-server/tty-server.factor
+++ b/extra/tty-server/tty-server.factor
@@ -1,4 +1,5 @@
-USING: listener io.servers.connection io.encodings.utf8 ;
+USING: listener io.servers.connection io.encodings.utf8
+accessors kernel ;
IN: tty-server
: <tty-server> ( port -- )
@@ -6,8 +7,9 @@ IN: tty-server
"tty-server" >>name
utf8 >>encoding
swap local-server >>insecure
- [ listener ] >>handler ;
+ [ listener ] >>handler
+ start-server ;
-: tty-server ( -- ) 9999 tty-server ;
+: tty-server ( -- ) 9999 <tty-server> ;
MAIN: tty-server
diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor
index 30c5d403de..a14d6d9823 100644
--- a/extra/webapps/counter/counter.factor
+++ b/extra/webapps/counter/counter.factor
@@ -1,5 +1,5 @@
USING: math kernel accessors http.server http.server.dispatchers
-furnace furnace.actions furnace.sessions
+furnace furnace.actions furnace.sessions furnace.redirection
html.components html.forms html.templates.chloe
fry urls ;
IN: webapps.counter
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
deleted file mode 100644
index c0bd856d5d..0000000000
--- a/extra/webapps/factor-website/factor-website.factor
+++ /dev/null
@@ -1,73 +0,0 @@
-! Copyright (c) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs io.files io.sockets
-io.server
-namespaces db db.tuples db.sqlite smtp
-logging.insomniac
-http.server
-http.server.dispatchers
-furnace.alloy
-furnace.auth.login
-furnace.auth.providers.db
-furnace.auth.features.edit-profile
-furnace.auth.features.recover-password
-furnace.auth.features.registration
-furnace.boilerplate
-webapps.blogs
-webapps.pastebin
-webapps.planet
-webapps.todo
-webapps.wiki
-webapps.wee-url
-webapps.user-admin ;
-IN: webapps.factor-website
-
-: test-db ( -- db params ) "resource:test.db" sqlite-db ;
-
-: init-factor-db ( -- )
- test-db [
- init-furnace-tables
-
- {
- post comment
- paste annotation
- blog posting
- todo
- short-url
- article revision
- } ensure-tables
- ] with-db ;
-
-TUPLE: factor-website < dispatcher ;
-
-: <factor-website> ( -- responder )
- factor-website new-dispatcher
- <blogs> "blogs" add-responder
- <todo-list> "todo" add-responder
- <pastebin> "pastebin" add-responder
- <planet-factor> "planet" add-responder
- <wiki> "wiki" add-responder
- <wee-url> "wee-url" add-responder
- <user-admin> "user-admin" add-responder
- "Factor website" <login-realm>
- "Factor website" >>name
- allow-registration
- allow-password-recovery
- allow-edit-profile
- <boilerplate>
- { factor-website "page" } >>template
- test-db <alloy> ;
-
-: init-factor-website ( -- )
- "factorcode.org" 25 <inet> smtp-server set-global
- "todo@factorcode.org" lost-password-from set-global
- "website@factorcode.org" insomniac-sender set-global
- "slava@factorcode.org" insomniac-recipients set-global
- init-factor-db
- <factor-website> main-responder set-global ;
-
-: start-factor-website ( -- )
- test-db start-expiring
- test-db start-update-task
- httpd-insomniac
- 8812 httpd ;
diff --git a/extra/webapps/factor-website/page.css b/extra/webapps/factor-website/page.css
deleted file mode 100644
index 49e26883ad..0000000000
--- a/extra/webapps/factor-website/page.css
+++ /dev/null
@@ -1,78 +0,0 @@
-body, button {
- font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#444;
-}
-
-.link-button {
- padding: 0px;
- background: none;
- border: none;
-}
-
-a, .link {
- color: #222;
- border-bottom:1px dotted #666;
- text-decoration:none;
-}
-
-a:hover, .link:hover {
- border-bottom:1px solid #66a;
-}
-
-.error { color: #a00; }
-
-.errors li { color: #a00; }
-
-.field-label {
- text-align: right;
-}
-
-.inline {
- display: inline;
-}
-
-.navbar {
- background-color: #eee;
- padding: 5px;
- border: 1px solid #ccc;
-}
-
-.big-field-label {
- vertical-align: top;
-}
-
-.description {
- padding: 5px;
- color: #000;
-}
-
-.description pre {
- border: 1px dashed #ccc;
- background-color: #f5f5f5;
-}
-
-.description p:first-child {
- margin-top: 0px;
-}
-
-.description p:last-child {
- margin-bottom: 0px;
-}
-
-.description table, .description td {
- border-color: #666;
- border-style: solid;
-}
-
-.description table {
- border-width: 0 0 1px 1px;
- border-spacing: 0;
- border-collapse: collapse;
-}
-
-.description td {
- margin: 0;
- padding: 4px;
- border-width: 1px 1px 0 0;
-}
-
diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml
deleted file mode 100644
index 32e1223c58..0000000000
--- a/extra/webapps/factor-website/page.xml
+++ /dev/null
@@ -1,28 +0,0 @@
-<?xml version='1.0' ?>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-
- <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <head>
- <t:write-title />
-
- <t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
-
- <t:style t:include="resource:extra/webapps/factor-website/page.css" />
-
- <t:write-style />
-
- <t:write-atom />
- </head>
-
- <body>
- <t:call-next-template />
- </body>
-
- </t:chloe>
-
-</html>
From 27c89d75d46120df04769c3a375a7af2aa626443 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Jun 2008 05:22:33 -0500
Subject: [PATCH 71/90] I/O micro-optimizations; 12% improvement on
reverse-complement
---
core/io/encodings/encodings.factor | 102 ++++++++++--------
core/optimizer/known-words/known-words.factor | 20 ++--
extra/io/encodings/ascii/ascii.factor | 7 +-
3 files changed, 70 insertions(+), 59 deletions(-)
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 4a9f90cb32..942476616f 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -28,23 +28,62 @@ ERROR: encode-error ;
! Decoding
-<PRIVATE
-
M: object <decoder> f decoder boa ;
+<PRIVATE
+
+: cr+ t >>cr drop ; inline
+
+: cr- f >>cr drop ; inline
+
: >decoder< ( decoder -- stream encoding )
- [ stream>> ] [ code>> ] bi ;
+ [ stream>> ] [ code>> ] bi ; inline
-: cr+ t swap set-decoder-cr ; inline
+: fix-read1 ( stream char -- char )
+ over cr>> [
+ over cr-
+ dup CHAR: \n = [
+ drop dup stream-read1
+ ] when
+ ] when nip ; inline
-: cr- f swap set-decoder-cr ; inline
+M: decoder stream-read1
+ dup >decoder< decode-char fix-read1 ;
+
+: fix-read ( stream string -- string )
+ over cr>> [
+ over cr-
+ "\n" ?head [
+ over stream-read1 [ suffix ] when*
+ ] when
+ ] when nip ; inline
+
+: (read) ( n quot -- n string )
+ over 0 <string> [
+ [
+ >r call dup
+ [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
+ ] 2curry find-integer
+ ] keep ; inline
+
+: finish-read ( n string -- string/f )
+ {
+ { [ over 0 = ] [ 2drop f ] }
+ { [ over not ] [ nip ] }
+ [ swap head ]
+ } cond ; inline
+
+M: decoder stream-read
+ tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ;
+
+M: decoder stream-read-partial stream-read ;
: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
: line-ends\r ( stream str -- str ) swap cr+ ; inline
: line-ends\n ( stream str -- str )
- over decoder-cr over empty? and
+ over cr>> over empty? and
[ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
: handle-readln ( stream str ch -- str )
@@ -52,61 +91,30 @@ M: object <decoder> f decoder boa ;
{ f [ line-ends/eof ] }
{ CHAR: \r [ line-ends\r ] }
{ CHAR: \n [ line-ends\n ] }
- } case ;
+ } case ; inline
-: fix-read ( stream string -- string )
- over decoder-cr [
- over cr-
- "\n" ?head [
- over stream-read1 [ suffix ] when*
- ] when
- ] when nip ;
-
-: read-loop ( n stream -- string )
- SBUF" " clone [
- [
- >r nip stream-read1 dup
- [ r> push f ] [ r> 2drop t ] if
- ] 2curry find-integer drop
- ] keep "" like f like ;
-
-M: decoder stream-read
- tuck read-loop fix-read ;
-
-M: decoder stream-read-partial stream-read ;
-
-: (read-until) ( buf quot -- string/f sep/f )
+: ((read-until)) ( buf quot -- string/f sep/f )
! quot: -- char stop?
dup call
[ >r drop "" like r> ]
- [ pick push (read-until) ] if ; inline
+ [ pick push ((read-until)) ] if ; inline
-M: decoder stream-read-until
+: (read-until) ( seps stream -- string/f sep/f )
SBUF" " clone -rot >decoder<
- [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
- (read-until) ;
+ [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
+ ((read-until)) ; inline
-: fix-read1 ( stream char -- char )
- over decoder-cr [
- over cr-
- dup CHAR: \n = [
- drop dup stream-read1
- ] when
- ] when nip ;
+M: decoder stream-read-until (read-until) ;
-M: decoder stream-read1
- dup >decoder< decode-char fix-read1 ;
+M: decoder stream-readln "\r\n" over (read-until) handle-readln ;
-M: decoder stream-readln ( stream -- str )
- "\r\n" over stream-read-until handle-readln ;
-
-M: decoder dispose decoder-stream dispose ;
+M: decoder dispose stream>> dispose ;
! Encoding
M: object <encoder> encoder boa ;
: >encoder< ( encoder -- stream encoding )
- [ stream>> ] [ code>> ] bi ;
+ [ stream>> ] [ code>> ] bi ; inline
M: encoder stream-write1
>encoder< encode-char ;
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index d1dbefe26b..970b69a18a 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -9,7 +9,7 @@ io.streams.string layouts splitting math.intervals
math.floats.private classes.tuple classes.tuple.private classes
classes.algebra optimizer.def-use optimizer.backend
optimizer.pattern-match optimizer.inlining float-arrays
-sequences.private combinators ;
+sequences.private combinators byte-arrays byte-vectors ;
{ <tuple> <tuple-boa> } [
[
@@ -59,15 +59,19 @@ sequences.private combinators ;
node-in-d peek dup value?
[ value-literal sequence? ] [ drop f ] if ;
-: member-quot ( seq -- newquot )
- [ literalize [ t ] ] { } map>assoc
- [ drop f ] suffix [ nip case ] curry ;
+: member-quot ( seq predicate -- newquot )
+ [ curry [ dup ] prepose [ drop t ] ] curry { } map>assoc
+ [ drop f ] suffix [ nip cond ] curry ;
-: expand-member ( #call -- )
- dup node-in-d peek value-literal member-quot f splice-quot ;
+: expand-member ( #call predicate -- )
+ >r dup node-in-d peek value-literal r> member-quot f splice-quot ;
\ member? {
- { [ dup literal-member? ] [ expand-member ] }
+ { [ dup literal-member? ] [ [ = ] expand-member ] }
+} define-optimizers
+
+\ memq? {
+ { [ dup literal-member? ] [ [ eq? ] expand-member ] }
} define-optimizers
! if the result of eq? is t and the second input is a literal,
@@ -97,7 +101,7 @@ sequences.private combinators ;
] each
\ push-all
-{ { string sbuf } { array vector } }
+{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop
\ append
diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor
index 9ff120c5fa..08dc8d07d9 100755
--- a/extra/io/encodings/ascii/ascii.factor
+++ b/extra/io/encodings/ascii/ascii.factor
@@ -5,12 +5,11 @@ IN: io.encodings.ascii
<PRIVATE
: encode-if< ( char stream encoding max -- )
- nip 1- pick < [ encode-error ] [ stream-write1 ] if ;
+ nip 1- pick < [ encode-error ] [ stream-write1 ] if ; inline
: decode-if< ( stream encoding max -- character )
- nip swap stream-read1
- [ tuck > [ drop replacement-char ] unless ]
- [ drop f ] if* ;
+ nip swap stream-read1 dup
+ [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii
From d17470b5fbf6f51f7d3f32a8f398b170e6f60e94 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Jun 2008 05:25:21 -0500
Subject: [PATCH 72/90] HTTPd test fixes
---
extra/http/http-tests.factor | 2 +-
extra/http/server/server.factor | 6 ++++++
2 files changed, 7 insertions(+), 1 deletion(-)
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index b5ed144579..a02382f083 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -125,7 +125,7 @@ USING: http.server http.server.static furnace.sessions furnace.alloy
furnace.actions furnace.auth furnace.auth.login furnace.db http.client
io.servers.connection io.files io io.encodings.ascii
accessors namespaces threads
-http.server.responses http.server.redirection
+http.server.responses http.server.redirection furnace.redirection
http.server.dispatchers db.tuples ;
: add-quit-action
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 0312e62e8d..21ab074907 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -144,5 +144,11 @@ M: http-server handle-client*
"http" protocol-port >>insecure
"https" protocol-port >>secure ;
+: httpd ( port -- )
+ <http-server>
+ swap >>insecure
+ f >>secure
+ start-server ;
+
: http-insomniac ( -- )
"http.server" { "httpd-hit" } schedule-insomniac ;
From 0c0aaceedb84a947d0127a404a4bdee07b858840 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 00:32:38 -0500
Subject: [PATCH 73/90] Better compilation of member? when the sequence
contains small integers only
---
core/optimizer/known-words/known-words.factor | 60 +++++++++++++++----
1 file changed, 50 insertions(+), 10 deletions(-)
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 970b69a18a..7f882d85d0 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
-inference.class kernel assocs math math.private kernel.private
-sequences words parser vectors strings sbufs io namespaces
-assocs quotations sequences.private io.binary
+inference.class kernel assocs math math.order math.private
+kernel.private sequences words parser vectors strings sbufs io
+namespaces assocs quotations sequences.private io.binary
io.streams.string layouts splitting math.intervals
math.floats.private classes.tuple classes.tuple.private classes
classes.algebra optimizer.def-use optimizer.backend
@@ -59,19 +59,59 @@ sequences.private combinators byte-arrays byte-vectors ;
node-in-d peek dup value?
[ value-literal sequence? ] [ drop f ] if ;
-: member-quot ( seq predicate -- newquot )
- [ curry [ dup ] prepose [ drop t ] ] curry { } map>assoc
- [ drop f ] suffix [ nip cond ] curry ;
+: expand-member ( #call quot -- )
+ >r dup node-in-d peek value-literal r> call f splice-quot ;
-: expand-member ( #call predicate -- )
- >r dup node-in-d peek value-literal r> member-quot f splice-quot ;
+: bit-member-n 256 ; inline
+
+: bit-member? ( seq -- ? )
+ #! Can we use a fast byte array test here?
+ {
+ { [ dup length 8 < ] [ f ] }
+ { [ dup [ integer? not ] contains? ] [ f ] }
+ { [ dup [ 0 < ] contains? ] [ f ] }
+ { [ dup [ bit-member-n >= ] contains? ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+: bit-member-seq ( seq -- flags )
+ bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
+
+: exact-float? ( f -- ? )
+ dup float? [ dup >integer >float = ] [ drop f ] if ; inline
+
+: bit-member-quot ( seq -- newquot )
+ [
+ [ drop ] % ! drop the sequence itself; we don't use it at run time
+ bit-member-seq ,
+ [
+ {
+ { [ over fixnum? ] [ ?nth 1 eq? ] }
+ { [ over bignum? ] [ ?nth 1 eq? ] }
+ { [ over exact-float? ] [ ?nth 1 eq? ] }
+ [ 2drop f ]
+ } cond
+ ] %
+ ] [ ] make ;
+
+: member-quot ( seq -- newquot )
+ dup bit-member? [
+ bit-member-quot
+ ] [
+ [ [ t ] ] { } map>assoc
+ [ drop f ] suffix [ nip case ] curry
+ ] if ;
\ member? {
- { [ dup literal-member? ] [ [ = ] expand-member ] }
+ { [ dup literal-member? ] [ [ member-quot ] expand-member ] }
} define-optimizers
+: memq-quot ( seq -- newquot )
+ [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
+ [ drop f ] suffix [ nip cond ] curry ;
+
\ memq? {
- { [ dup literal-member? ] [ [ eq? ] expand-member ] }
+ { [ dup literal-member? ] [ [ memq-quot ] expand-member ] }
} define-optimizers
! if the result of eq? is t and the second input is a literal,
From dc3929f3db12a47e20798567aba8c2754a24459b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 00:35:19 -0500
Subject: [PATCH 74/90] Improve PEG: word
---
extra/peg/parsers/parsers.factor | 2 --
extra/peg/peg.factor | 25 ++++++++++++++++++-------
2 files changed, 18 insertions(+), 9 deletions(-)
diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor
index 443b9fc61d..da44c12e8f 100755
--- a/extra/peg/parsers/parsers.factor
+++ b/extra/peg/parsers/parsers.factor
@@ -24,11 +24,9 @@ MEMO: just ( parser -- parser )
: 1token ( ch -- parser ) 1string token ;
-<PRIVATE
: (list-of) ( items separator repeat1? -- parser )
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ unclip 1vector swap first append ] action ;
-PRIVATE>
: list-of ( items separator -- parser )
hide f (list-of) ;
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index b420574a3b..05f84afedb 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings fry namespaces math assocs shuffle
+USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order
unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
@@ -563,11 +563,22 @@ PRIVATE>
#! to fix boxes so this isn't needed...
box-parser boa next-id f <parser> over set-delegate [ ] action ;
+ERROR: parse-failed input word ;
+
+M: parse-failed error.
+ "The " write dup word>> pprint " word could not parse the following input:" print nl
+ input>> . ;
+
: PEG:
- (:) [
+ (:)
+ [let* | def [ ] word [ ] compiled-def [ def call compile ] |
[
- call compile [ compiled-parse ] curry
- [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
- append define
- ] with-compilation-unit
- ] 2curry over push-all ; parsing
+ [
+ [
+ dup compiled-def compiled-parse
+ [ ast>> ] [ word parse-failed ] ?if
+ ]
+ word swap define
+ ] with-compilation-unit
+ ] over push-all
+ ] ; parsing
From c19d83e13f5b9330a09a7d74b5b7a01a3e403fba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 00:35:34 -0500
Subject: [PATCH 75/90] Use fry in html
---
extra/html/elements/elements.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor
index 5fc4bd19ae..35e01227b5 100644
--- a/extra/html/elements/elements.factor
+++ b/extra/html/elements/elements.factor
@@ -5,7 +5,7 @@
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
-urls math math.parser combinators present ;
+urls math math.parser combinators present fry ;
IN: html.elements
@@ -70,7 +70,7 @@ SYMBOL: html
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
- dup <foo> swap [ <foo> write-html ] curry
+ dup <foo> swap '[ , <foo> write-html ]
(( -- )) html-word ;
: <foo ( str -- <str ) "<" prepend ;
@@ -78,7 +78,7 @@ SYMBOL: html
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
- <foo dup [ write-html ] curry
+ <foo dup '[ , write-html ]
(( -- )) html-word ;
: foo> ( str -- foo> ) ">" append ;
@@ -93,14 +93,14 @@ SYMBOL: html
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
- </foo> dup [ write-html ] curry (( -- )) html-word ;
+ </foo> dup '[ , write-html ] (( -- )) html-word ;
: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
- dup <foo/> swap [ <foo/> write-html ] curry
+ dup <foo/> swap '[ , <foo/> write-html ]
(( -- )) html-word ;
: foo/> ( str -- str/> ) "/>" append ;
@@ -134,7 +134,7 @@ SYMBOL: html
: define-attribute-word ( name -- )
dup "=" prepend swap
- [ write-attr ] curry (( string -- )) html-word ;
+ '[ , write-attr ] (( string -- )) html-word ;
! Define some closed HTML tags
[
From 9674541cebfbb6bddfc135f3b3c9af892615236a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 00:36:20 -0500
Subject: [PATCH 76/90] New http request/response parsers using pegs
---
extra/http/http-tests.factor | 49 ++++++-
extra/http/http.factor | 224 ++++++++++++++----------------
extra/http/parsers/parsers.factor | 166 ++++++++++++++++++++++
3 files changed, 315 insertions(+), 124 deletions(-)
create mode 100644 extra/http/parsers/parsers.factor
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index a02382f083..522d0c1845 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -1,7 +1,8 @@
USING: http tools.test multiline tuple-syntax
io.streams.string io.encodings.utf8 io.encodings.string
kernel arrays splitting sequences
-assocs io.sockets db db.sqlite continuations urls hashtables ;
+assocs io.sockets db db.sqlite continuations urls hashtables
+accessors ;
IN: http.tests
: lf>crlf "\n" split "\r\n" join ;
@@ -73,10 +74,21 @@ GET nested HTTP/1.0
;
-[ read-request-test-3 [ read-request ] with-string-reader ]
+[ read-request-test-3 lf>crlf [ read-request ] with-string-reader ]
[ "Bad request: URL" = ]
must-fail-with
+STRING: read-request-test-4
+GET /blah HTTP/1.0
+Host: "www.amazon.com"
+;
+
+[ "www.amazon.com" ]
+[
+ read-request-test-4 lf>crlf [ read-request ] with-string-reader
+ "host" header
+] unit-test
+
STRING: read-response-test-1
HTTP/1.1 404 not found
Content-Type: text/html; charset=UTF-8
@@ -117,7 +129,38 @@ read-response-test-1' 1array [
[ t ] [
"rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
- dup parse-cookies unparse-cookies =
+ dup parse-set-cookie first unparse-set-cookie =
+] unit-test
+
+[ t ] [
+ "a="
+ dup parse-set-cookie first unparse-set-cookie =
+] unit-test
+
+STRING: read-response-test-2
+HTTP/1.1 200 Content follows
+Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
+
+
+;
+
+[ 2 ] [
+ read-response-test-2 lf>crlf
+ [ read-response ] with-string-reader
+ cookies>> length
+] unit-test
+
+STRING: read-response-test-3
+HTTP/1.1 200 Content follows
+Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
+
+
+;
+
+[ 1 ] [
+ read-response-test-3 lf>crlf
+ [ read-response ] with-string-reader
+ cookies>> length
] unit-test
! Live-fire exercise
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 025e2c8441..4001301cb1 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -1,8 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators math namespaces
-
-assocs sequences splitting sorting sets debugger
+assocs assocs.lib sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
@@ -11,7 +10,9 @@ io.encodings.8-bit
unicode.case unicode.categories qualified
-urls html.templates xml xml.data xml.writer ;
+urls html.templates xml xml.data xml.writer
+
+http.parsers ;
EXCLUDE: fry => , ;
@@ -19,40 +20,20 @@ IN: http
: crlf ( -- ) "\r\n" write ;
-: add-header ( value key assoc -- )
- [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
-
-: header-line ( line -- )
- dup first blank? [
- [ blank? ] left-trim
- "last-header" get
- "header" get
- add-header
- ] [
- ":" split1 dup [
- [ blank? ] left-trim
- swap >lower dup "last-header" set
- "header" get add-header
- ] [
- 2drop
- ] if
- ] if ;
-
-: read-lf ( -- bytes )
- "\n" read-until CHAR: \n assert= ;
-
: read-crlf ( -- bytes )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
-: (read-header) ( -- )
- read-crlf dup
- empty? [ drop ] [ header-line (read-header) ] if ;
+: (read-header) ( -- alist )
+ [ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ;
+
+: process-header ( alist -- assoc )
+ f swap [ [ swap or dup ] dip swap ] assoc-map nip
+ [ ?push ] histogram [ "; " join ] assoc-map
+ >hashtable ;
: read-header ( -- assoc )
- H{ } clone [
- "header" [ (read-header) ] with-variable
- ] keep ;
+ (read-header) process-header ;
: header-value>string ( value -- string )
{
@@ -63,47 +44,62 @@ IN: http
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
- dup "\r\n" intersect empty?
+ dup "\r\n\"" intersect empty?
[ "Header injection attack" throw ] unless ;
: write-header ( assoc -- )
>alist sort-keys [
- swap
- check-header-string write ": " write
- header-value>string check-header-string write crlf
+ [ check-header-string write ": " write ]
+ [ header-value>string check-header-string write crlf ] bi*
] assoc-each crlf ;
-TUPLE: cookie name value path domain expires max-age http-only ;
+TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
: <cookie> ( value name -- cookie )
cookie new
swap >>name
swap >>value ;
-: parse-cookies ( string -- seq )
+: parse-set-cookie ( string -- seq )
[
f swap
-
- ";" split [
- [ blank? ] trim "=" split1 swap >lower {
+ (parse-set-cookie)
+ [
+ swap {
+ { "version" [ >>version ] }
+ { "comment" [ >>comment ] }
{ "expires" [ cookie-string>timestamp >>expires ] }
{ "max-age" [ string>number seconds >>max-age ] }
{ "domain" [ >>domain ] }
{ "path" [ >>path ] }
{ "httponly" [ drop t >>http-only ] }
- { "" [ drop ] }
+ { "secure" [ drop t >>secure ] }
[ <cookie> dup , nip ]
} case
- ] each
+ ] assoc-each
+ drop
+ ] { } make ;
+: parse-cookie ( string -- seq )
+ [
+ f swap
+ (parse-cookie)
+ [
+ swap {
+ { "$version" [ >>version ] }
+ { "$domain" [ >>domain ] }
+ { "$path" [ >>path ] }
+ [ <cookie> dup , nip ]
+ } case
+ ] assoc-each
drop
] { } make ;
: check-cookie-string ( string -- string' )
- dup "=;'\"" intersect empty?
+ dup "=;'\"\r\n" intersect empty?
[ "Bad cookie name or value" throw ] unless ;
-: (unparse-cookie) ( key value -- )
+: unparse-cookie-value ( key value -- )
{
{ f [ drop ] }
{ t [ check-cookie-string , ] }
@@ -118,20 +114,30 @@ TUPLE: cookie name value path domain expires max-age http-only ;
]
} case ;
-: unparse-cookie ( cookie -- strings )
+: (unparse-cookie) ( cookie -- strings )
[
dup name>> check-cookie-string >lower
- over value>> (unparse-cookie)
- "path" over path>> (unparse-cookie)
- "domain" over domain>> (unparse-cookie)
- "expires" over expires>> (unparse-cookie)
- "max-age" over max-age>> (unparse-cookie)
- "httponly" over http-only>> (unparse-cookie)
+ over value>> unparse-cookie-value
+ "$path" over path>> unparse-cookie-value
+ "$domain" over domain>> unparse-cookie-value
drop
] { } make ;
-: unparse-cookies ( cookies -- string )
- [ unparse-cookie ] map concat "; " join ;
+: unparse-cookie ( cookies -- string )
+ [ (unparse-cookie) ] map concat "; " join ;
+
+: unparse-set-cookie ( cookie -- string )
+ [
+ dup name>> check-cookie-string >lower
+ over value>> unparse-cookie-value
+ "path" over path>> unparse-cookie-value
+ "domain" over domain>> unparse-cookie-value
+ "expires" over expires>> unparse-cookie-value
+ "max-age" over max-age>> unparse-cookie-value
+ "httponly" over http-only>> unparse-cookie-value
+ "secure" over secure>> unparse-cookie-value
+ drop
+ ] { } make "; " join ;
TUPLE: request
method
@@ -141,6 +147,13 @@ header
post-data
cookies ;
+: check-url ( string -- url )
+ >url dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
+
+: read-request-line ( request -- request )
+ read-crlf parse-request-line first3
+ [ >>method ] [ check-url >>url ] [ >>version ] tri* ;
+
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
@@ -155,27 +168,9 @@ cookies ;
"close" "connection" set-header
"Factor http.client" "user-agent" set-header ;
-: read-method ( request -- request )
- " " read-until [ "Bad request: method" throw ] unless
- >>method ;
-
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
-: read-url ( request -- request )
- " " read-until [
- dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
- ] [ "Bad request: URL" throw ] if ;
-
-: parse-version ( string -- version )
- "HTTP/" ?head [ "Bad request: version" throw ] unless
- dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
-
-: read-request-version ( request -- request )
- read-crlf [ CHAR: \s = ] left-trim
- parse-version
- >>version ;
-
: read-request-header ( request -- request )
read-header >>header ;
@@ -210,7 +205,7 @@ TUPLE: post-data raw content content-type ;
drop ;
: extract-cookies ( request -- request )
- dup "cookie" header [ parse-cookies >>cookies ] when* ;
+ dup "cookie" header [ parse-cookie >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
@@ -220,22 +215,18 @@ TUPLE: post-data raw content content-type ;
: read-request ( -- request )
<request>
- read-method
- read-url
- read-request-version
+ read-request-line
read-request-header
read-post-data
extract-host
extract-cookies ;
-: write-method ( request -- request )
- dup method>> write bl ;
-
-: write-request-url ( request -- request )
- dup url>> relative-url present write bl ;
-
-: write-version ( request -- request )
- "HTTP/" write dup request-version write crlf ;
+: write-request-line ( request -- request )
+ dup
+ [ method>> write bl ]
+ [ url>> relative-url present write bl ]
+ [ "HTTP/" write version>> write crlf ]
+ tri ;
: url-host ( url -- string )
[ host>> ] [ port>> ] bi dup "http" protocol-port =
@@ -249,7 +240,7 @@ TUPLE: post-data raw content content-type ;
[ content-type>> "content-type" pick set-at ]
bi
] when*
- over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
+ over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
write-header ;
GENERIC: >post-data ( object -- post-data )
@@ -274,9 +265,7 @@ M: f >post-data ;
: write-request ( request -- )
unparse-post-data
- write-method
- write-request-url
- write-version
+ write-request-line
write-request-header
write-post-data
flush
@@ -311,23 +300,13 @@ M: response clone
[ clone ] change-header
[ clone ] change-cookies ;
-: read-response-version ( response -- response )
- " \t" read-until
- [ "Bad response: version" throw ] unless
- parse-version
- >>version ;
-
-: read-response-code ( response -- response )
- " \t" read-until [ "Bad response: code" throw ] unless
- string>number [ "Bad response: code" throw ] unless*
- >>code ;
-
-: read-response-message ( response -- response )
- read-crlf >>message ;
+: read-response-line ( response -- response )
+ read-crlf parse-response-line first3
+ [ >>version ] [ >>code ] [ >>message ] tri* ;
: read-response-header ( response -- response )
read-header >>header
- dup "set-cookie" header parse-cookies >>cookies
+ dup "set-cookie" header parse-set-cookie >>cookies
dup "content-type" header [
parse-content-type
[ >>content-type ]
@@ -336,20 +315,15 @@ M: response clone
: read-response ( -- response )
<response>
- read-response-version
- read-response-code
- read-response-message
+ read-response-line
read-response-header ;
-: write-response-version ( response -- response )
- "HTTP/" write
- dup version>> write bl ;
-
-: write-response-code ( response -- response )
- dup code>> number>string write bl ;
-
-: write-response-message ( response -- response )
- dup message>> write crlf ;
+: write-response-line ( response -- response )
+ dup
+ [ "HTTP/" write version>> write bl ]
+ [ code>> present write bl ]
+ [ message>> write crlf ]
+ tri ;
: unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ]
@@ -357,19 +331,29 @@ M: response clone
bi
[ "; charset=" swap 3append ] when* ;
+: ensure-domain ( cookie -- cookie )
+ [
+ request get url>>
+ host>> dup "localhost" =
+ [ drop ] [ or ] if
+ ] change-domain ;
+
: write-response-header ( response -- response )
- dup header>> clone
- over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
+ #! We send one set-cookie header per cookie, because that's
+ #! what Firefox expects.
+ dup header>> >alist >vector
over unparse-content-type "content-type" pick set-at
+ over cookies>> [
+ ensure-domain unparse-set-cookie
+ "set-cookie" swap 2array over push
+ ] each
write-header ;
: write-response-body ( response -- response )
dup body>> call-template ;
M: response write-response ( respose -- )
- write-response-version
- write-response-code
- write-response-message
+ write-response-line
write-response-header
flush
drop ;
@@ -403,9 +387,7 @@ body ;
"1.1" >>version ;
M: raw-response write-response ( respose -- )
- write-response-version
- write-response-code
- write-response-message
+ write-response-line
write-response-body
drop ;
diff --git a/extra/http/parsers/parsers.factor b/extra/http/parsers/parsers.factor
new file mode 100644
index 0000000000..33bfa4b202
--- /dev/null
+++ b/extra/http/parsers/parsers.factor
@@ -0,0 +1,166 @@
+USING: math math.order math.parser kernel combinators.lib
+sequences sequences.deep peg peg.parsers assocs arrays
+hashtables strings unicode.case namespaces ascii ;
+IN: http.parsers
+
+: except ( quot -- parser )
+ [ not ] compose satisfy ; inline
+
+: except-these ( quots -- parser )
+ [ 1|| ] curry except ; inline
+
+: ctl? ( ch -- ? )
+ { [ 0 31 between? ] [ 127 = ] } 1|| ;
+
+: tspecial? ( ch -- ? )
+ "()<>@,;:\\\"/[]?={} \t" member? ;
+
+: 'token' ( -- parser )
+ { [ ctl? ] [ tspecial? ] } except-these repeat1 ;
+
+: case-insensitive ( parser -- parser' )
+ [ flatten >string >lower ] action ;
+
+: case-sensitive ( parser -- parser' )
+ [ flatten >string ] action ;
+
+: 'space' ( -- parser )
+ [ " \t" member? ] satisfy repeat0 hide ;
+
+: one-of ( strings -- parser )
+ [ token ] map choice ;
+
+: 'http-method' ( -- parser )
+ { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ;
+
+: 'url' ( -- parser )
+ [ " \t\r\n" member? ] except repeat1 case-sensitive ;
+
+: 'http-version' ( -- parser )
+ [
+ "HTTP" token hide ,
+ 'space' ,
+ "/" token hide ,
+ 'space' ,
+ "1" token ,
+ "." token ,
+ { "0" "1" } one-of ,
+ ] seq* [ concat >string ] action ;
+
+PEG: parse-request-line ( string -- triple )
+ #! Triple is { method url version }
+ [
+ 'space' ,
+ 'http-method' ,
+ 'space' ,
+ 'url' ,
+ 'space' ,
+ 'http-version' ,
+ 'space' ,
+ ] seq* just ;
+
+: 'text' ( -- parser )
+ [ ctl? ] except ;
+
+: 'response-code' ( -- parser )
+ [ digit? ] satisfy 3 exactly-n [ string>number ] action ;
+
+: 'response-message' ( -- parser )
+ 'text' repeat0 case-sensitive ;
+
+PEG: parse-response-line ( string -- triple )
+ #! Triple is { version code message }
+ [
+ 'space' ,
+ 'http-version' ,
+ 'space' ,
+ 'response-code' ,
+ 'space' ,
+ 'response-message' ,
+ ] seq* just ;
+
+: 'crlf' ( -- parser )
+ "\r\n" token ;
+
+: 'lws' ( -- parser )
+ [ " \t" member? ] satisfy repeat1 ;
+
+: 'qdtext' ( -- parser )
+ { [ CHAR: " = ] [ ctl? ] } except-these ;
+
+: 'quoted-char' ( -- parser )
+ "\\" token hide any-char 2seq ;
+
+: 'quoted-string' ( -- parser )
+ 'quoted-char' 'qdtext' 2choice repeat0 "\"" "\"" surrounded-by ;
+
+: 'ctext' ( -- parser )
+ { [ ctl? ] [ "()" member? ] } except-these ;
+
+: 'comment' ( -- parser )
+ 'ctext' 'comment' 2choice repeat0 "(" ")" surrounded-by ;
+
+: 'field-name' ( -- parser )
+ 'token' case-insensitive ;
+
+: 'field-content' ( -- parser )
+ 'quoted-string' case-sensitive
+ 'text' repeat0 case-sensitive
+ 2choice ;
+
+PEG: parse-header-line ( string -- pair )
+ #! Pair is either { name value } or { f value }. If f, its a
+ #! continuation of the previous header line.
+ [
+ 'field-name' ,
+ 'space' ,
+ ":" token hide ,
+ 'space' ,
+ 'field-content' ,
+ ] seq*
+ [
+ 'lws' [ drop f ] action ,
+ 'field-content' ,
+ ] seq*
+ 2choice ;
+
+: 'word' ( -- parser )
+ 'token' 'quoted-string' 2choice ;
+
+: 'value' ( -- parser )
+ 'quoted-string'
+ [ ";" member? ] except repeat0
+ 2choice case-sensitive ;
+
+: 'attr' ( -- parser )
+ 'token' case-insensitive ;
+
+: 'av-pair' ( -- parser )
+ [
+ 'space' ,
+ 'attr' ,
+ 'space' ,
+ [ "=" token , 'space' , 'value' , ] seq* [ peek ] action
+ epsilon [ drop f ] action
+ 2choice ,
+ 'space' ,
+ ] seq* ;
+
+: 'av-pairs' ( -- parser )
+ 'av-pair' ";" token list-of optional ;
+
+PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
+
+: 'cookie-value' ( -- parser )
+ [
+ 'space' ,
+ 'attr' ,
+ 'space' ,
+ "=" token hide ,
+ 'space' ,
+ 'value' ,
+ 'space' ,
+ ] seq* ;
+
+PEG: (parse-cookie) ( string -- alist )
+ 'cookie-value' [ ";," member? ] satisfy list-of optional just ;
From 9453415eb5f9196a3a7de44dd33ae27d0efd1ebb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 00:37:04 -0500
Subject: [PATCH 77/90] https support
---
extra/furnace/auth/auth.factor | 27 +++++++++++++++-----
extra/furnace/auth/login/login.factor | 13 +++++++---
extra/furnace/boilerplate/boilerplate.factor | 8 +++++-
extra/furnace/redirection/redirection.factor | 16 ++++++++++--
4 files changed, 51 insertions(+), 13 deletions(-)
diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor
index d9f517aaf4..ae042f05bd 100755
--- a/extra/furnace/auth/auth.factor
+++ b/extra/furnace/auth/auth.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
-destructors combinators
+destructors combinators fry
io.encodings.utf8 io.encodings.string io.binary random
checksums checksums.sha2
html.forms
@@ -10,6 +10,7 @@ http.server.filters
http.server.dispatchers
furnace
furnace.actions
+furnace.redirection
furnace.boilerplate
furnace.auth.providers
furnace.auth.providers.db ;
@@ -54,7 +55,7 @@ V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get adjoin ;
-TUPLE: realm < dispatcher name users checksum ;
+TUPLE: realm < dispatcher name users checksum secure ;
GENERIC: login-required* ( realm -- response )
@@ -67,7 +68,8 @@ GENERIC: logged-in-username ( realm -- username )
swap >>name
swap >>default
users-in-db >>users
- sha-256 >>checksum ; inline
+ sha-256 >>checksum
+ t >>secure ; inline
: users ( -- provider )
realm get users>> ;
@@ -104,6 +106,16 @@ M: realm call-responder* ( path responder -- response )
: check-login ( password username -- user/f )
users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
+: if-secure-realm ( quot -- )
+ realm get secure>> [ if-secure ] [ call ] if ; inline
+
+TUPLE: secure-realm-only < filter-responder ;
+
+C: <secure-realm-only> secure-realm-only
+
+M: secure-realm-only call-responder*
+ '[ , , call-next-method ] if-secure-realm ;
+
TUPLE: protected < filter-responder description capabilities ;
: <protected> ( responder -- protected )
@@ -118,9 +130,12 @@ TUPLE: protected < filter-responder description capabilities ;
} cond ;
M: protected call-responder* ( path responder -- response )
- dup protected set
- dup logged-in-user get check-capabilities
- [ call-next-method ] [ 2drop realm get login-required* ] if ;
+ '[
+ , ,
+ dup protected set
+ dup logged-in-user get check-capabilities
+ [ call-next-method ] [ 2drop realm get login-required* ] if
+ ] if-secure-realm ;
: <auth-boilerplate> ( responder -- responder' )
<boilerplate> { realm "boilerplate" } >>template ;
diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index 4c53cb9c89..68161382c1 100755
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -39,8 +39,11 @@ M: login-realm modify-form ( responder -- )
: <permit-cookie> ( -- cookie )
permit-id get realm get name>> permit-id-key <cookie>
"$login-realm" resolve-base-path >>path
- realm get timeout>> from-now >>expires
- realm get domain>> >>domain ;
+ realm get
+ [ timeout>> from-now >>expires ]
+ [ domain>> >>domain ]
+ [ secure>> >>secure ]
+ tri ;
: put-permit-cookie ( response -- response' )
<permit-cookie> put-cookie ;
@@ -82,7 +85,9 @@ SYMBOL: capabilities
"password" value
"username" value check-login
[ successful-login ] [ login-failed ] if*
- ] >>submit ;
+ ] >>submit
+ <auth-boilerplate>
+ <secure-realm-only> ;
: <logout-action> ( -- action )
<action>
@@ -99,6 +104,6 @@ M: login-realm login-required*
: <login-realm> ( responder name -- auth )
login-realm new-realm
- <login-action> <auth-boilerplate> "login" add-responder
+ <login-action> "login" add-responder
<logout-action> "logout" add-responder
20 minutes >>timeout ;
diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor
index a976199661..0e2a673d9b 100644
--- a/extra/furnace/boilerplate/boilerplate.factor
+++ b/extra/furnace/boilerplate/boilerplate.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces
+USING: accessors kernel math.order namespaces combinators.lib
html.forms
html.templates
html.templates.chloe
@@ -17,6 +17,12 @@ TUPLE: boilerplate < filter-responder template init ;
swap >>responder
[ ] >>init ;
+: wrap-boilerplate? ( response -- ? )
+ {
+ [ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ]
+ [ content-type>> "text/html" = ]
+ } 1&& ;
+
M:: boilerplate call-responder* ( path responder -- )
begin-form
path responder call-next-method
diff --git a/extra/furnace/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor
index 7f87c677b9..88d621b573 100644
--- a/extra/furnace/redirection/redirection.factor
+++ b/extra/furnace/redirection/redirection.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators namespaces
+USING: kernel accessors combinators namespaces fry
io.servers.connection
-http http.server http.server.redirection
+http http.server http.server.redirection http.server.filters
furnace ;
IN: furnace.redirection
@@ -27,3 +27,15 @@ TUPLE: redirect-responder to ;
redirect-responder boa ;
M: redirect-responder call-responder* nip to>> <redirect> ;
+
+TUPLE: secure-only < filter-responder ;
+
+C: <secure-only> secure-only
+
+: if-secure ( quot -- )
+ >r request get url>> protocol>> "http" =
+ [ request get url>> <secure-redirect> ]
+ r> if ; inline
+
+M: secure-only call-responder*
+ '[ , , call-next-method ] if-secure ;
From 21d3380bf229ccc856b2afc4e7550d84aa6192c2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 00:50:10 -0500
Subject: [PATCH 78/90] Bootstrap fix
---
core/optimizer/known-words/known-words.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 7f882d85d0..d69a2f94bc 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -98,7 +98,7 @@ sequences.private combinators byte-arrays byte-vectors ;
dup bit-member? [
bit-member-quot
] [
- [ [ t ] ] { } map>assoc
+ [ literalize [ t ] ] { } map>assoc
[ drop f ] suffix [ nip case ] curry
] if ;
From 83099e01d4ecb4670c05f12e33023f211769d4f3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 00:58:29 -0500
Subject: [PATCH 79/90] Fixing PEG:
---
extra/peg/peg.factor | 12 +++++++-----
1 file changed, 7 insertions(+), 5 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 05f84afedb..3d3b4ad626 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -571,14 +571,16 @@ M: parse-failed error.
: PEG:
(:)
- [let* | def [ ] word [ ] compiled-def [ def call compile ] |
+ [let | word [ ] def [ ] |
[
[
- [
- dup compiled-def compiled-parse
- [ ast>> ] [ word parse-failed ] ?if
+ [let | compiled-def [ def call compile ]
+ [
+ dup compiled-def compiled-parse
+ [ ast>> ] [ word parse-failed ] ?if
+ ]
+ word swap define
]
- word swap define
] with-compilation-unit
] over push-all
] ; parsing
From e55c674a2bf97bbf87a38aba0db752d6b03edae4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 01:18:39 -0500
Subject: [PATCH 80/90] Fix again
---
extra/peg/peg.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 3d3b4ad626..54c25778de 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -571,10 +571,10 @@ M: parse-failed error.
: PEG:
(:)
- [let | word [ ] def [ ] |
+ [let | def [ ] word [ ] |
[
[
- [let | compiled-def [ def call compile ]
+ [let | compiled-def [ def call compile ] |
[
dup compiled-def compiled-parse
[ ast>> ] [ word parse-failed ] ?if
From 6d2ded44f28c0be26dbe33bfb9231f18a1db9d85 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 01:40:48 -0500
Subject: [PATCH 81/90] Launcher fix
---
extra/io/unix/launcher/launcher.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 7f6b3396a1..365e51749d 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -31,7 +31,7 @@ USE: unix
] when* ;
: redirect-fd ( oldfd fd -- )
- 2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ;
+ 2dup = [ 2drop ] [ dup2 io-error ] if ;
: reset-fd ( fd -- )
#! We drop the error code because on *BSD, fcntl of
From 6aa23fd7a2c93cff05fd89c3260abc281140a14c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 01:52:50 -0500
Subject: [PATCH 82/90] Fix http.client load error'
---
extra/http/client/client.factor | 10 +++-------
1 file changed, 3 insertions(+), 7 deletions(-)
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index 56957b021c..0b9224f171 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -79,13 +79,9 @@ ERROR: download-failed response body ;
M: download-failed error.
"HTTP download failed:" print nl
- [
- response>>
- write-response-code
- write-response-message nl
- drop
- ]
- [ body>> write ] bi ;
+ [ response>> write-response-line nl drop ]
+ [ body>> write ]
+ bi ;
: check-response ( response data -- response data )
over code>> success? [ download-failed ] unless ;
From ef29b725b8be7927a9f112ab2b5f699ca97aa260 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 01:59:29 -0500
Subject: [PATCH 83/90] Fix ftp.server load error
---
extra/ftp/server/server.factor | 18 +++++++++++++-----
1 file changed, 13 insertions(+), 5 deletions(-)
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index cce69dde0f..c71eadb72f 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.8-bit
io.encodings io.encodings.binary io.encodings.utf8 io.files
-io.server io.sockets kernel math.parser namespaces sequences
+io.sockets kernel math.parser namespaces sequences
ftp io.unix.launcher.parser unicode.case splitting assocs
-classes io.server destructors calendar io.timeouts
+classes io.servers.connection destructors calendar io.timeouts
io.streams.duplex threads continuations math
concurrency.promises byte-arrays ;
IN: ftp.server
@@ -305,7 +305,10 @@ ERROR: not-a-directory ;
[ drop unrecognized-command t ]
} case [ handle-client-loop ] when ;
-: handle-client ( -- )
+TUPLE: ftp-server < threaded-server ;
+
+M: ftp-server handle-client* ( server -- )
+ drop
[
"" [
host-name <ftp-client> client set
@@ -313,9 +316,14 @@ ERROR: not-a-directory ;
] with-directory
] with-destructors ;
+: <ftp-server> ( port -- server )
+ ftp-server new-threaded-server
+ swap >>insecure
+ "ftp.server" >>name
+ latin1 >>encoding ;
+
: ftpd ( port -- )
- internet-server "ftp.server"
- latin1 [ handle-client ] with-server ;
+ <ftp-server> start-server ;
: ftpd-main ( -- ) 2100 ftpd ;
From 1260a87468dd1a83f6d35b38d3ac60844186ad30 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 02:52:49 -0500
Subject: [PATCH 84/90] Debugging 'recover password'
---
.../features/recover-password/recover-1.xml | 2 +-
.../features/recover-password/recover-3.xml | 2 +-
.../features/recover-password/recover-4.xml | 2 +-
.../recover-password/recover-password.factor | 30 +++++++++----------
4 files changed, 18 insertions(+), 18 deletions(-)
diff --git a/extra/furnace/auth/features/recover-password/recover-1.xml b/extra/furnace/auth/features/recover-password/recover-1.xml
index 21fbe6fd39..46e52d5319 100644
--- a/extra/furnace/auth/features/recover-password/recover-1.xml
+++ b/extra/furnace/auth/features/recover-password/recover-1.xml
@@ -6,7 +6,7 @@
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
- <t:form t:action="recover-password">
+ <t:form t:action="$realm/recover-password">
<table>
diff --git a/extra/furnace/auth/features/recover-password/recover-3.xml b/extra/furnace/auth/features/recover-password/recover-3.xml
index 2e412d1f18..a71118ea31 100644
--- a/extra/furnace/auth/features/recover-password/recover-3.xml
+++ b/extra/furnace/auth/features/recover-password/recover-3.xml
@@ -6,7 +6,7 @@
<p>Choose a new password for your account.</p>
- <t:form t:action="new-password">
+ <t:form t:action="$realm/recover-3">
<table>
diff --git a/extra/furnace/auth/features/recover-password/recover-4.xml b/extra/furnace/auth/features/recover-password/recover-4.xml
index f5d02fa858..d71a01bc25 100755
--- a/extra/furnace/auth/features/recover-password/recover-4.xml
+++ b/extra/furnace/auth/features/recover-password/recover-4.xml
@@ -4,6 +4,6 @@
<t:title>Recover lost password: step 4 of 4</t:title>
- <p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>
+ <p>Your password has been reset. You may now <t:a t:href="$realm">proceed</t:a>.</p>
</t:chloe>
diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor
index 806df024f0..93b3a7ad73 100644
--- a/extra/furnace/auth/features/recover-password/recover-password.factor
+++ b/extra/furnace/auth/features/recover-password/recover-password.factor
@@ -1,8 +1,9 @@
! Copyright (c) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors kernel assocs arrays io.sockets threads
-fry urls smtp validators html.forms
-http http.server.responses http.server.dispatchers
+fry urls smtp validators html.forms present
+http http.server.responses http.server.redirection
+http.server.dispatchers
furnace furnace.actions furnace.auth furnace.auth.providers
furnace.redirection ;
IN: furnace.auth.features.recover-password
@@ -13,13 +14,12 @@ SYMBOL: lost-password-from
request get url>> host>> host-name or ;
: new-password-url ( user -- url )
- "recover-3"
- swap [
- [ username>> "username" set ]
- [ ticket>> "ticket" set ]
+ URL" recover-3" clone
+ swap
+ [ username>> "username" set-query-param ]
+ [ ticket>> "ticket" set-query-param ]
bi
- ] H{ } make-assoc
- derive-url ;
+ adjust-url relative-to-request ;
: password-email ( user -- email )
<email>
@@ -35,7 +35,7 @@ SYMBOL: lost-password-from
"If you believe that this request was legitimate, you may click the below link in\n" %
"your browser to set a new password for your account:\n" %
"\n" %
- swap new-password-url %
+ swap new-password-url present %
"\n\n" %
"Love,\n" %
"\n" %
@@ -48,7 +48,7 @@ SYMBOL: lost-password-from
: <recover-action-1> ( -- action )
<page-action>
- { realm "recover-1" } >>template
+ { realm "features/recover-password/recover-1" } >>template
[
{
@@ -64,12 +64,12 @@ SYMBOL: lost-password-from
send-password-email
] when*
- URL" $login/recover-2" <redirect>
+ URL" $realm/recover-2" <redirect>
] >>submit ;
: <recover-action-2> ( -- action )
<page-action>
- { realm "recover-2" } >>template ;
+ { realm "features/recover-password/recover-2" } >>template ;
: <recover-action-3> ( -- action )
<page-action>
@@ -80,7 +80,7 @@ SYMBOL: lost-password-from
} validate-params
] >>init
- { realm "recover-3" } >>template
+ { realm "features/recover-password/recover-3" } >>template
[
{
@@ -100,7 +100,7 @@ SYMBOL: lost-password-from
"new-password" value >>encoded-password
users update-user
- URL" $login/recover-4" <redirect>
+ URL" $realm/recover-4" <redirect>
] [
<403>
] if*
@@ -108,7 +108,7 @@ SYMBOL: lost-password-from
: <recover-action-4> ( -- action )
<page-action>
- { realm "recover-4" } >>template ;
+ { realm "features/recover-password/recover-4" } >>template ;
: allow-password-recovery ( login -- login )
<recover-action-1> <auth-boilerplate>
From ef6807a4dd6786c349abb93ccbfdfb458d5a26a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 02:54:11 -0500
Subject: [PATCH 85/90] Tweak
---
extra/websites/concatenative/concatenative.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor
index fcf98b08da..1e79b043e2 100644
--- a/extra/websites/concatenative/concatenative.factor
+++ b/extra/websites/concatenative/concatenative.factor
@@ -63,8 +63,8 @@ TUPLE: factor-website < dispatcher ;
: init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
- "todo@factorcode.org" lost-password-from set-global
- "website@factorcode.org" insomniac-sender set-global
+ "noreply@concatenative.org" lost-password-from set-global
+ "website@concatenative.org" insomniac-sender set-global
"slava@factorcode.org" insomniac-recipients set-global
init-factor-db
<factor-website> main-responder set-global ;
From 9ce8116fad5a079343eebef63d0cac7176927570 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 03:16:45 -0500
Subject: [PATCH 86/90] Fix 'delete user'
---
extra/webapps/user-admin/user-admin.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor
index 359730d4b2..f445b6f471 100644
--- a/extra/webapps/user-admin/user-admin.factor
+++ b/extra/webapps/user-admin/user-admin.factor
@@ -139,7 +139,7 @@ TUPLE: user-admin < dispatcher ;
<action>
[
validate-username
- <user> select-tuple 1 >>deleted update-tuple
+ "username" value <user> select-tuple 1 >>deleted update-tuple
URL" $user-admin" <redirect>
] >>submit ;
From db6b24614fbfadf820a97af19a3cbc7299cf7ba4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 03:26:50 -0500
Subject: [PATCH 87/90] Improving user-admin tool
---
.../deactivate-user/deactivate-user.factor | 22 +++++++++++++++++++
.../features/edit-profile/edit-profile.xml | 3 +++
.../features/registration/registration.factor | 5 +++--
extra/html/templates/chloe/chloe.factor | 5 ++---
extra/webapps/user-admin/user-admin.factor | 2 +-
.../concatenative/concatenative.factor | 2 ++
6 files changed, 33 insertions(+), 6 deletions(-)
create mode 100644 extra/furnace/auth/features/deactivate-user/deactivate-user.factor
diff --git a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor
new file mode 100644
index 0000000000..49fa00353b
--- /dev/null
+++ b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs namespaces accessors db db.tuples urls
+http.server.dispatchers
+furnace.asides furnace.actions furnace.auth furnace.auth.providers ;
+IN: furnace.auth.features.deactivate-user
+
+: <deactivate-user-action> ( -- action )
+ <action>
+ [
+ logged-in-user get
+ 1 >>deleted
+ t >>changed?
+ drop
+ URL" $realm" end-aside
+ ] >>submit ;
+
+: allow-deactivation ( realm -- realm )
+ <deactivate-user-action> "deactivate-user" add-responder ;
+
+: allow-deactivation? ( -- ? )
+ realm get responders>> "deactivate-user" swap key? ;
diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml
index 011cc2bdf8..a9d7994e97 100644
--- a/extra/furnace/auth/features/edit-profile/edit-profile.xml
+++ b/extra/furnace/auth/features/edit-profile/edit-profile.xml
@@ -67,4 +67,7 @@
</t:form>
+ <t:if t:code="furnace.auth.features.deactivate-user:allow-deactivation?">
+ <t:button t:action="$realm/deactivate-user">Delete User</t:button>
+ </t:if>
</t:chloe>
diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor
index 5c1851fb64..20a48d07d2 100644
--- a/extra/furnace/auth/features/registration/registration.factor
+++ b/extra/furnace/auth/features/registration/registration.factor
@@ -35,10 +35,11 @@ IN: furnace.auth.features.registration
realm get init-user-profile
URL" $realm" <redirect>
- ] >>submit ;
+ ] >>submit
+ <auth-boilerplate> ;
: allow-registration ( login -- login )
- <register-action> <auth-boilerplate> "register" add-responder ;
+ <register-action> "register" add-responder ;
: allow-registration? ( -- ? )
realm get responders>> "register" swap key? ;
diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor
index 32fe954178..103020ee0f 100644
--- a/extra/html/templates/chloe/chloe.factor
+++ b/extra/html/templates/chloe/chloe.factor
@@ -87,11 +87,10 @@ CHLOE: comment drop ;
CHLOE: call-next-template drop call-next-template ;
: attr>word ( value -- word/f )
- dup ":" split1 swap lookup
- [ ] [ "No such word: " swap append throw ] ?if ;
+ ":" split1 swap lookup ;
: if-satisfied? ( tag -- ? )
- [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
+ [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
[ "value" optional-attr [ value ] [ t ] if* ]
bi and ;
diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor
index f445b6f471..2137abbc2d 100644
--- a/extra/webapps/user-admin/user-admin.factor
+++ b/extra/webapps/user-admin/user-admin.factor
@@ -139,7 +139,7 @@ TUPLE: user-admin < dispatcher ;
<action>
[
validate-username
- "username" value <user> select-tuple 1 >>deleted update-tuple
+ "username" value <user> delete-tuples
URL" $user-admin" <redirect>
] >>submit ;
diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor
index 1e79b043e2..a4f826d7f6 100644
--- a/extra/websites/concatenative/concatenative.factor
+++ b/extra/websites/concatenative/concatenative.factor
@@ -13,6 +13,7 @@ furnace.auth.providers.db
furnace.auth.features.edit-profile
furnace.auth.features.recover-password
furnace.auth.features.registration
+furnace.auth.features.deactivate-user
furnace.boilerplate
furnace.redirection
webapps.blogs
@@ -57,6 +58,7 @@ TUPLE: factor-website < dispatcher ;
allow-registration
allow-password-recovery
allow-edit-profile
+ allow-deactivation
<boilerplate>
{ factor-website "page" } >>template
test-db <alloy> ;
From 5a133ceeceab676eff63174e90b6232771a576c0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 03:28:15 -0500
Subject: [PATCH 88/90] Security
---
.../auth/features/deactivate-user/deactivate-user.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor
index 49fa00353b..cf6a56c2d4 100644
--- a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor
+++ b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor
@@ -16,7 +16,9 @@ IN: furnace.auth.features.deactivate-user
] >>submit ;
: allow-deactivation ( realm -- realm )
- <deactivate-user-action> "deactivate-user" add-responder ;
+ <deactivate-user-action> <protected>
+ "delete your profile" >>description
+ "deactivate-user" add-responder ;
: allow-deactivation? ( -- ? )
realm get responders>> "deactivate-user" swap key? ;
From 4e1e14566943ec4574a498f54dd359bbe123826f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 03:40:05 -0500
Subject: [PATCH 89/90] Tweaking config some more
---
.../concatenative/concatenative.factor | 30 ++++++++++++++-----
1 file changed, 22 insertions(+), 8 deletions(-)
diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor
index a4f826d7f6..6d65f10783 100644
--- a/extra/websites/concatenative/concatenative.factor
+++ b/extra/websites/concatenative/concatenative.factor
@@ -63,19 +63,33 @@ TUPLE: factor-website < dispatcher ;
{ factor-website "page" } >>template
test-db <alloy> ;
-: init-factor-website ( -- )
- "factorcode.org" 25 <inet> smtp-server set-global
+SYMBOL: key-password
+SYMBOL: key-file
+SYMBOL: dh-file
+
+: common-configuration ( -- )
+ "concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global
"slava@factorcode.org" insomniac-recipients set-global
- init-factor-db
- <factor-website> main-responder set-global ;
+ <factor-website> main-responder set-global
+ init-factor-db ;
+
+: init-testing ( -- )
+ "resource:extra/openssl/test/dh1024.pem" dh-file set-global
+ "resource:extra/openssl/test/server.pem" key-file set-global
+ "password" key-password set-global
+ common-configuration ;
+
+: init-production ( -- )
+ "/home/slava/cert/host.pem" key-file set-global
+ common-configuration ;
: <factor-secure-config> ( -- config )
<secure-config>
- "resource:extra/openssl/test/server.pem" >>key-file
- "resource:extra/openssl/test/dh1024.pem" >>dh-file
- "password" >>password ;
+ key-file get >>key-file
+ dh-file get >>dh-file
+ key-password get >>password ;
: <factor-website-server> ( -- threaded-server )
<http-server>
@@ -83,7 +97,7 @@ TUPLE: factor-website < dispatcher ;
8080 >>insecure
8431 >>secure ;
-: start-factor-website ( -- )
+: start-website ( -- )
test-db start-expiring
test-db start-update-task
http-insomniac
From ebb3423e4a5138c4d4985fd080278b298613a4b9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 03:53:16 -0500
Subject: [PATCH 90/90] Fix assocs.lib tests
---
extra/assocs/lib/lib-tests.factor | 4 ++++
extra/assocs/lib/lib.factor | 2 +-
2 files changed, 5 insertions(+), 1 deletion(-)
create mode 100644 extra/assocs/lib/lib-tests.factor
diff --git a/extra/assocs/lib/lib-tests.factor b/extra/assocs/lib/lib-tests.factor
new file mode 100644
index 0000000000..0bf8270088
--- /dev/null
+++ b/extra/assocs/lib/lib-tests.factor
@@ -0,0 +1,4 @@
+IN: assocs.lib.tests
+USING: assocs.lib tools.test vectors ;
+
+{ 1 1 } [ [ ?push ] histogram ] must-infer-as
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index 1c89c1eb16..14632df771 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -41,4 +41,4 @@ IN: assocs.lib
: histogram ( assoc quot -- assoc' )
H{ } clone [
swap [ change-at ] 2curry assoc-each
- ] keep ;
+ ] keep ; inline