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

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

db4
Eduardo Cavazos 2007-12-05 22:28:17 -06:00
parent 6efd5260ad 4eb4982e60
commit b6a0e2fea1
3 changed files with 77 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
extra/rss/rss.factor
View File

@ -74,7 +74,7 @@ C: <entry> entry
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
http-get rot 200 = [
http-get-stream rot 200 = [
nip read-feed
] [
2drop "Error retrieving newsfeed file" throw
@ -84,12 +84,15 @@ C: <entry> entry
: simple-tag, ( content name -- )
[ , ] tag, ;
: simple-tag*, ( content name attrs -- )
[ , ] tag*, ;
: entry, ( entry -- )
"entry" [
dup entry-title "title" simple-tag,
dup entry-title "title" { { "type" "html" } } simple-tag*,
"link" over entry-link "href" associate contained*,
dup entry-pub-date "published" simple-tag,
entry-description "content" simple-tag,
entry-description "content" { { "type" "html" } } simple-tag*,
] tag, ;
: feed>xml ( feed -- xml )

135
extra/webapps/planet/planet.factor
View File

@ -1,41 +1,14 @@
USING: sequences rss arrays concurrency kernel sorting
html.elements io assocs namespaces math threads vocabs html
furnace http.server.templating calendar math.parser splitting
continuations debugger system http.server.responders ;
continuations debugger system http.server.responders
xml.writer ;
IN: webapps.planet
TUPLE: posting author title date link body ;
: diagnostic write print flush ;
: fetch-feed ( pair -- feed )
second
dup "Fetching " diagnostic
dup download-feed feed-entries
swap "Done fetching " diagnostic ;
: fetch-blogroll ( blogroll -- entries )
#! entries is an array of { author entries } pairs.
dup [
[ fetch-feed ] [ error. drop f ] recover
] parallel-map
[ [ >r first r> 2array ] curry* map ] 2map concat ;
: sort-entries ( entries -- entries' )
[ [ second entry-pub-date ] compare ] sort <reversed> ;
: <posting> ( pair -- posting )
#! pair has shape { author entry }
first2
{ entry-title entry-pub-date entry-link entry-description }
get-slots posting construct-boa ;
: print-posting-summary ( posting -- )
<p "news" =class p>
<b> dup posting-title write </b> <br/>
"- " write
dup posting-author write bl
<a posting-link =href "more" =class a>
<b> dup entry-title write </b> <br/>
<a entry-link =href "more" =class a>
"Read More..." write
</a>
</p> ;
@ -63,14 +36,16 @@ TUPLE: posting author title date link body ;
: print-posting ( posting -- )
<h2 "posting-title" =class h2>
<a dup posting-link =href a>
dup posting-title write-html
" - " write
dup posting-author write
<a dup entry-link =href a>
dup entry-title write-html
</a>
</h2>
<p "posting-body" =class p> dup posting-body write-html </p>
<p "posting-date" =class p> posting-date format-date write </p> ;
<p "posting-body" =class p>
dup entry-description write-html
</p>
<p "posting-date" =class p>
entry-pub-date format-date write
</p> ;
: print-postings ( postings -- )
[ print-posting ] each ;
@ -83,38 +58,56 @@ TUPLE: posting author title date link body ;
SYMBOL: default-blogroll
SYMBOL: cached-postings
: update-cached-postings ( -- )
default-blogroll get fetch-blogroll sort-entries
[ <posting> ] map
cached-postings set-global ;
: mini-planet-factor ( -- )
cached-postings get 4 head print-posting-summaries ;
: planet-factor ( -- )
serving-html [
"resource:extra/webapps/planet/planet.fhtml"
run-template-file
] with-html-stream ;
serving-html [ "planet" render-template ] with-html-stream ;
\ planet-factor { } define-action
{
{ "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
{ "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "http://www.bluishcoder.co.nz/" }
{ "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
{ "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
{ "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
{ "Kio M. Smallwood"
"http://sekenre.wordpress.com/feed/atom/"
"http://sekenre.wordpress.com/" }
{ "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
{ "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
{ "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
} default-blogroll set-global
: planet-feed ( -- feed )
"[ planet-factor ]"
"http://planet.factorcode.org"
cached-postings get 30 head <feed> ;
: feed.xml
"text/xml" serving-content
planet-feed feed>xml write-xml ;
\ feed.xml { } define-action
SYMBOL: last-update
: diagnostic write print flush ;
: fetch-feed ( triple -- feed )
second
dup "Fetching " diagnostic
dup download-feed feed-entries
swap "Done fetching " diagnostic ;
: <posting> ( author entry -- entry' )
clone
[ ": " swap entry-title 3append ] keep
[ set-entry-title ] keep ;
: ?fetch-feed ( triple -- feed/f )
[ fetch-feed ] [ error. drop f ] recover ;
: fetch-blogroll ( blogroll -- entries )
dup 0 <column>
swap [ ?fetch-feed ] parallel-map
[ [ <posting> ] curry* map ] 2map concat ;
: sort-entries ( entries -- entries' )
[ [ entry-pub-date ] compare ] sort <reversed> ;
: update-cached-postings ( -- )
default-blogroll get
fetch-blogroll sort-entries
cached-postings set-global ;
: update-thread ( -- )
millis last-update set-global
[ update-cached-postings ] in-thread
@ -126,14 +119,16 @@ SYMBOL: last-update
"planet" "planet-factor" "extra/webapps/planet" web-app
: merge-feeds ( feeds -- feed )
[ feed-entries ] map concat sort-entries ;
: planet-feed ( -- feed )
default-blogroll get [ second download-feed ] map merge-feeds
>r "[ planet-factor ]" "http://planet.factorcode.org" r> <entry>
feed>xml ;
: feed.xml planet-feed ;
\ feed.xml { } define-action
{
{ "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
{ "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "http://www.bluishcoder.co.nz/" }
{ "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
{ "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
{ "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
{ "Kio M. Smallwood"
"http://sekenre.wordpress.com/feed/atom/"
"http://sekenre.wordpress.com/" }
! { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
{ "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
{ "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
} default-blogroll set-global

7
extra/webapps/planet/planet.fhtml → extra/webapps/planet/planet.furnace
View File

@ -9,6 +9,7 @@
<title>planet-factor</title>
<link rel="stylesheet" href="/responder/file/css/news.css" type="text/css" media="screen" title="no title" charset="utf-8" />
<link rel="alternate" type="application/atom+xml" title="Planet Factor - Atom" href="feed.xml" />
</head>
<body id="index">
@ -23,7 +24,11 @@
<a href="http://planet.lisp.org">Planet Lisp</a>.
</p>
<p>
This webapp is written in <a href="http://factorcode.org/">Factor</a>.
<img src="http://planet.lisp.org/feed-icon-14x14.png" />
<a href="feed.xml"> Syndicate </a>
</p>
<p>
This webapp is written in <a href="http://factorcode.org/">Factor</a>.<br>
<% "webapps.planet" browse-webapp-source %>
</p>
<h2 class="blogroll-title">Blogroll</h2>