apps/rss/rss-reader.factor

   1 ! Copyright (C) 2006 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 ! Create a test database like follows:
   5 !
   6 !   sqlite3 history.db
   7 !   > create table rss (url text, title text, link text, primary key (url));
   8 !   > create table entries (url text, link text, title text, description text, pubdate text, primary key(url, link));
   9 !   > [eof]
  10 !
  11 IN: rss
  12 USING: kernel html cont-responder namespaces sequences io hashtables sqlite errors tuple-db ;
  13
  14 TUPLE: reader-feed url title link ;
  15 TUPLE: reader-entry url link title description pubdate ;
  16
  17 reader-feed default-mapping set-mapping
  18 reader-entry default-mapping set-mapping
  19
  20 SYMBOL: db
  21
  22 : init-db ( -- )
  23   db get-global [ sqlite-close ] when*
  24   "rss-reader.db" exists? [
  25     "rss-reader.db" sqlite-open db set-global
  26   ] [
  27     "rss-reader.db" sqlite-open dup db set-global
  28     dup reader-feed create-tuple-table
  29     reader-entry create-tuple-table
  30   ] if ;
  31
  32 : add-feed ( url -- )
  33   "" "" <reader-feed> db get swap insert-tuple ;
  34
  35 : remove-feed ( url -- )
  36   f f <reader-feed> db get swap find-tuples [ db get swap delete-tuple ] each ;
  37
  38 : all-urls ( -- urls )
  39   f f f <reader-feed> db get swap find-tuples [ reader-feed-url ] map ;
  40
  41 : ask-for-url ( -- url )
  42   [
  43     <html>
  44       <head> <title> "Enter a Feed URL" write </title> </head>
  45       <body>
  46         <form =action "post" =method form>
  47           "URL: " write
  48           <input "text" =type "url" =name "100" =size input/>
  49           <input "submit" =type input/>
  50         </form>
  51       </body>
  52     </html>
  53   ] show "url" swap hash ;
  54
  55 : get-entries ( url -- entries )
  56   f f f f <reader-entry> db get swap find-tuples ;
  57
  58 : display-entries ( url -- )
  59   [
  60     <html>
  61       <head> <title> "View entries for " write over write </title> </head>
  62       <body>
  63         swap get-entries [
  64          <h2> dup reader-entry-title write </h2>
  65          <p>
  66            reader-entry-description write
  67          </p>
  68         ] each
  69         <p> <a =href a> "Back" write </a> </p>
  70       </body>
  71     </html>
  72   ] show 2drop ;
  73
  74 : rss>reader-feed ( url rss -- reader-feed )
  75   [ rss-title ] keep rss-link <reader-feed> ;
  76
  77 : rss-entry>reader-entry ( url entry -- reader-entry )
  78   [ rss-entry-link ] keep
  79   [ rss-entry-title ] keep
  80   [ rss-entry-description ] keep
  81   rss-entry-pub-date
  82   <reader-entry> ;
  83
  84 : update-feed-database ( url -- )
  85   dup remove-feed
  86   dup rss-get
  87   2dup rss>reader-feed db get swap save-tuple
  88   rss-entries [
  89     dupd rss-entry>reader-entry
  90     dup >r reader-entry-link f f f <reader-entry> db get swap find-tuples [ db get swap delete-tuple ] each r>
  91     db get swap save-tuple
  92   ] each-with ;
  93
  94 : update-feeds ( seq -- )
  95   [ update-feed-database ] each
  96   [
  97     <html>
  98       <head> <title> "Feeds Updated" write </title> </head>
  99       <body>
 100         <p> "Feeds Updated." write </p>
 101         <p> <a =href a> "Back" write </a> </p>
 102       </body>
 103     </html>
 104   ] show drop ;
 105
 106 : maintain-feeds ( -- )
 107   [
 108     <html>
 109       <head> <title> "Maintain Feeds" write </title> </head>
 110       <body>
 111         <p>
 112           <table "1" =border table>
 113             all-urls [
 114               <tr>
 115                 <td> dup write </td>
 116                 <td> dup [ remove-feed ] curry "Remove" swap quot-href </td>
 117                 <td> [ display-entries ] curry "Database" swap quot-href </td>
 118               </tr>
 119             ] each
 120           </table>
 121         </p>
 122         <p> "Add Feed" [ ask-for-url add-feed ] quot-href </p>
 123         <p> "Update Feeds" [ all-urls update-feeds ] quot-href </p>
 124       </body>
 125     </html>
 126   ] show-final ;
 127
 128 "maintain-feeds" [ init-db maintain-feeds ] install-cont-responder