From 35bd6202ef21ec5f4b9276413eb604126600053c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Oct 2007 16:44:40 -0400 Subject: [PATCH] Fix webapps/help bug --- extra/html/html.factor | 7 +- extra/webapps/help/help.factor | 9 ++- extra/webapps/planet/planet.factor | 118 +++++++++++++++++++++++++++++ extra/webapps/planet/planet.fhtml | 39 ++++++++++ 4 files changed, 168 insertions(+), 5 deletions(-) create mode 100644 extra/webapps/planet/planet.factor create mode 100644 extra/webapps/planet/planet.fhtml diff --git a/extra/html/html.factor b/extra/html/html.factor index 9db97957a5..137cc473d3 100644 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -35,8 +35,11 @@ TUPLE: html-sub-stream style stream ; stdio get delegate stream-write ; : object-link-tag ( style quot -- ) - presented pick at browser-link-href - [ call ] [ call ] if* ; inline + presented pick at [ + browser-link-href [ + call + ] [ call ] if* + ] [ call ] if* ; inline : hex-color, ( triplet -- ) 3 head-slice diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index 366baffcb9..8456e499f1 100644 --- a/extra/webapps/help/help.factor +++ b/extra/webapps/help/help.factor @@ -20,8 +20,8 @@ IN: webapps.help } define-action M: link browser-link-href - link-name - dup word? [ + link-name + dup word? over f eq? or [ browser-link-href ] [ dup array? [ " " join ] when @@ -32,10 +32,13 @@ M: link browser-link-href lookup show-help ; \ show-word { - { "vocab" "kernel" v-default } { "word" "call" v-default } + { "vocab" "kernel" v-default } } define-action +M: f browser-link-href + drop \ f browser-link-href ; + M: word browser-link-href dup word-name swap word-vocabulary [ show-word ] 2curry quot-link ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor new file mode 100644 index 0000000000..bdbb1ccd29 --- /dev/null +++ b/extra/webapps/planet/planet.factor @@ -0,0 +1,118 @@ +USING: sequences rss arrays concurrency kernel sorting +html.elements io assocs namespaces math threads vocabs html +furnace http.server.templating calendar math.parser splitting ; +IN: webapps.planet + +TUPLE: posting author title date link body ; + +: diagnostic write print flush ; + +: fetch-feed ( pair -- feed ) + second + dup "Fetching " diagnostic + dup news-get 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 [ ] subset + [ [ >r first r> 2array ] curry* map ] 2map concat ; + +: sort-entries ( entries -- entries' ) + [ [ second entry-pub-date ] compare ] sort ; + +: ( 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 -- ) +

+ dup posting-title write
+ "- " write + dup posting-author write bl + + "Read More..." write + +

; + +: print-posting-summaries ( postings -- ) + [ print-posting-summary ] each ; + +: print-blogroll ( blogroll -- ) + ; + +: format-date ( date -- string ) + 10 head "-" split [ string>number ] map + first3 0 0 0 0 + [ + dup timestamp-day # + " " % + dup timestamp-month month-abbreviations nth % + ", " % + timestamp-year # + ] "" make ; + +: print-posting ( posting -- ) +

+ + dup posting-title write + " - " write + dup posting-author write + +

+

dup posting-body write-html

+

posting-date format-date write

; + +: print-postings ( postings -- ) + [ print-posting ] each ; + +: browse-webapp-source ( vocab -- ) + vocab-link browser-link-href =href a> + "Browse source" write + ; + +SYMBOL: default-blogroll +SYMBOL: cached-postings + +: update-cached-postings ( -- ) + default-blogroll get fetch-blogroll sort-entries + [ ] map + cached-postings set-global ; + +: mini-planet-factor ( -- ) + cached-postings get 4 head print-posting-summaries ; + +: planet-factor ( -- ) + [ + "resource:extra/webapps/planet/planet.fhtml" + run-template-file + ] with-html-stream ; + +\ planet-factor { } define-action + +{ + { "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/" } + { "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 + +: update-thread ( -- ) + [ update-cached-postings ] try + 10 60 * 1000 * sleep + update-thread ; + +: start-update-thread ( -- ) + [ update-thread ] in-thread ; + +"planet" "planet-factor" "extra/webapps/planet" web-app diff --git a/extra/webapps/planet/planet.fhtml b/extra/webapps/planet/planet.fhtml new file mode 100644 index 0000000000..fb5a673077 --- /dev/null +++ b/extra/webapps/planet/planet.fhtml @@ -0,0 +1,39 @@ +<% USING: namespaces html.elements webapps.planet sequences ; %> + + + + + + + + planet-factor + + + + +

[ planet-factor ]

+ + + + + +
<% cached-postings get 20 head print-postings %> +

+ planet-factor is an Atom/RSS aggregator that collects the + contents of Factor-related blogs. It is inspired by + Planet Lisp. +

+

+ This webapp is written in Factor. + <% "webapps.planet" browse-webapp-source %> +

+

Blogroll

+ <% default-blogroll get print-blogroll %> +

+ If you want your weblog added to the blogroll, just ask. +

+
+ + +