rss reader example
chris.double
parent
2a70071e28
commit
b311fa01f2
|
|
@ -0,0 +1,5 @@
|
||||||
|
REQUIRES: httpd sqlite ;
|
||||||
|
PROVIDE: rss {
|
||||||
|
"rss.factor"
|
||||||
|
"rss-reader.factor"
|
||||||
|
} { } ;
|
||||||
|
|
@ -0,0 +1,150 @@
|
||||||
|
! Copyright (C) 2006 Chris Double.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
!
|
||||||
|
! Create a test database like follows:
|
||||||
|
!
|
||||||
|
! sqlite3 history.db
|
||||||
|
! > create table rss (url text, title text, link text, primary key (url));
|
||||||
|
! > create table entries (url text, link text, title text, description text, pubdate text, primary key(url, link));
|
||||||
|
! > [eof]
|
||||||
|
!
|
||||||
|
IN: rss
|
||||||
|
USING: kernel html cont-responder namespaces sequences io hashtables sqlite errors ;
|
||||||
|
|
||||||
|
SYMBOL: feeds
|
||||||
|
|
||||||
|
: init-feeds ( -- )
|
||||||
|
V{ } clone feeds set-global ;
|
||||||
|
|
||||||
|
: add-feed ( url -- )
|
||||||
|
feeds get push ;
|
||||||
|
|
||||||
|
: remove-feed ( url -- )
|
||||||
|
feeds get remove feeds set-global ;
|
||||||
|
|
||||||
|
: get-feed ( -- url )
|
||||||
|
[
|
||||||
|
<html>
|
||||||
|
<head> <title> "Enter a Feed URL" write </title> </head>
|
||||||
|
<body>
|
||||||
|
<form =action "post" =method form>
|
||||||
|
"URL: " write
|
||||||
|
<input "text" =type "url" =name "100" =size input/>
|
||||||
|
<input "submit" =type input/>
|
||||||
|
</form>
|
||||||
|
</body>
|
||||||
|
</html>
|
||||||
|
] show "url" swap hash ;
|
||||||
|
|
||||||
|
: get-entries ( url -- )
|
||||||
|
"history.db" sqlite-open ( db )
|
||||||
|
"select * from entries where url='" rot append "'" append dupd sqlite-prepare ( db stmt )
|
||||||
|
[ [ [ 2 column-text ] keep
|
||||||
|
[ 1 column-text ] keep
|
||||||
|
[ 3 column-text ] keep
|
||||||
|
4 column-text <rss-entry>
|
||||||
|
] sqlite-map
|
||||||
|
] keep
|
||||||
|
sqlite-finalize
|
||||||
|
swap sqlite-close ;
|
||||||
|
|
||||||
|
: view-entries ( url -- )
|
||||||
|
[
|
||||||
|
<html>
|
||||||
|
<head> <title> "View entries for " write over write </title> </head>
|
||||||
|
<body>
|
||||||
|
swap get-entries [
|
||||||
|
<h2> dup rss-entry-title write </h2>
|
||||||
|
<p>
|
||||||
|
rss-entry-description write
|
||||||
|
</p>
|
||||||
|
] each
|
||||||
|
<p> <a =href a> "Back" write </a> </p>
|
||||||
|
</body>
|
||||||
|
</html>
|
||||||
|
] show 2drop ;
|
||||||
|
|
||||||
|
: rss-delete-statement ( url -- string )
|
||||||
|
[
|
||||||
|
"delete from rss where url='" % % "';" % ] "" make ;
|
||||||
|
|
||||||
|
: rss-insert-statement ( url rss -- string )
|
||||||
|
[
|
||||||
|
"insert into rss values('" % swap % "','" %
|
||||||
|
[ rss-title "'" "''" rot replace % "','" % ] keep
|
||||||
|
rss-link % "');" %
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
: entry-delete-statement ( url entry -- string )
|
||||||
|
[
|
||||||
|
"delete from entries where url='" % swap % "' and link='" %
|
||||||
|
rss-entry-link "'" "''" rot replace % "';" %
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
: entry-insert-statement ( url entry -- string )
|
||||||
|
[
|
||||||
|
"insert into entries values('" % swap % "','" %
|
||||||
|
[ rss-entry-link "'" "''" rot replace % "','" % ] keep
|
||||||
|
[ rss-entry-title "'" "''" rot replace % "','" % ] keep
|
||||||
|
[ rss-entry-description "'" "''" rot replace % "','" % ] keep
|
||||||
|
rss-entry-pub-date "'" "''" rot replace % "');" %
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
: do-update ( string -- )
|
||||||
|
"history.db" sqlite-open ( db )
|
||||||
|
dup rot sqlite-prepare [ [ drop ] sqlite-each ] keep
|
||||||
|
sqlite-finalize
|
||||||
|
sqlite-close ;
|
||||||
|
|
||||||
|
: update-feed-database ( url rss -- )
|
||||||
|
over rss-delete-statement do-update
|
||||||
|
2dup rss-insert-statement do-update ( url rss - )
|
||||||
|
rss-entries [ ( url entry )
|
||||||
|
2dup entry-delete-statement do-update
|
||||||
|
entry-insert-statement do-update
|
||||||
|
] each-with ;
|
||||||
|
|
||||||
|
: update-feeds ( seq -- )
|
||||||
|
[
|
||||||
|
[
|
||||||
|
dup rss-get
|
||||||
|
] catch [
|
||||||
|
update-feed-database
|
||||||
|
] unless
|
||||||
|
] each
|
||||||
|
[
|
||||||
|
<html>
|
||||||
|
<head> <title> "Feeds Updated" write </title> </head>
|
||||||
|
<body>
|
||||||
|
<p> "Feeds Updated." write </p>
|
||||||
|
<p> <a =href a> "Back" write </a> </p>
|
||||||
|
</body>
|
||||||
|
</html>
|
||||||
|
] show drop ;
|
||||||
|
|
||||||
|
: maintain-feeds ( -- )
|
||||||
|
[
|
||||||
|
<html>
|
||||||
|
<head> <title> "Maintain Feeds" write </title> </head>
|
||||||
|
<body>
|
||||||
|
<p>
|
||||||
|
<table "1" =border table>
|
||||||
|
feeds get [
|
||||||
|
<tr>
|
||||||
|
<td> dup write </td>
|
||||||
|
<td> dup [ remove-feed ] curry "Remove" swap quot-href </td>
|
||||||
|
<td> [ view-entries ] curry "Database" swap quot-href </td>
|
||||||
|
</tr>
|
||||||
|
] each
|
||||||
|
</table>
|
||||||
|
</p>
|
||||||
|
<p> "Add Feed" [ get-feed add-feed ] quot-href </p>
|
||||||
|
<p> "Update Feeds" [ feeds get update-feeds ] quot-href </p>
|
||||||
|
</body>
|
||||||
|
</html>
|
||||||
|
] show-final ;
|
||||||
|
|
||||||
|
init-feeds
|
||||||
|
|
||||||
|
|
||||||
|
"maintain-feeds" [ maintain-feeds ] install-cont-responder
|
||||||
|
|
@ -1,6 +1,5 @@
|
||||||
! Copyright (C) 2006 Chris Double.
|
! Copyright (C) 2006 Chris Double.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
REQUIRES: httpd ;
|
|
||||||
IN: rss
|
IN: rss
|
||||||
USING: kernel http-client sequences namespaces math errors io ;
|
USING: kernel http-client sequences namespaces math errors io ;
|
||||||
|
|
||||||
|
|
@ -10,8 +9,8 @@ USING: kernel http-client sequences namespaces math errors io ;
|
||||||
drop % 2drop
|
drop % 2drop
|
||||||
] [
|
] [
|
||||||
dup ( str1 str2 string n n-1 )
|
dup ( str1 str2 string n n-1 )
|
||||||
pick head % ( str1 str2 string n )
|
pick swap head % ( str1 str2 string n )
|
||||||
>r pick length r> + swap tail ( str1 str2 tail )
|
>r pick length r> + tail ( str1 str2 tail )
|
||||||
over % (replace)
|
over % (replace)
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
@ -106,6 +105,3 @@ TUPLE: rss-entry title link description pub-date ;
|
||||||
] [
|
] [
|
||||||
2drop "Error retrieving rss file" throw
|
2drop "Error retrieving rss file" throw
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
||||||
PROVIDE: rss ;
|
|
||||||
Loading…
Reference in New Issue