extra/webapps/planet/planet.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors sequences sorting math math.order
   4 calendar alarms logging concurrency.combinators namespaces
   5 sequences.lib db.types db.tuples db fry locals hashtables
   6 html.components
   7 syndication urls xml.writer
   8 validators
   9 http.server
  10 http.server.dispatchers
  11 furnace
  12 furnace.actions
  13 furnace.boilerplate
  14 furnace.auth.login
  15 furnace.auth
  16 furnace.syndication ;
  17 IN: webapps.planet
  18
  19 TUPLE: planet-factor < dispatcher ;
  20
  21 TUPLE: planet-factor-admin < dispatcher ;
  22
  23 TUPLE: blog id name www-url feed-url ;
  24
  25 M: blog link-title name>> ;
  26
  27 M: blog link-href www-url>> ;
  28
  29 blog "BLOGS"
  30 {
  31     { "id" "ID" INTEGER +db-assigned-id+ }
  32     { "name" "NAME" { VARCHAR 256 } +not-null+ }
  33     { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
  34     { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
  35 } define-persistent
  36
  37 TUPLE: posting < entry id ;
  38
  39 posting "POSTINGS"
  40 {
  41     { "id" "ID" INTEGER +db-assigned-id+ }
  42     { "title" "TITLE" { VARCHAR 256 } +not-null+ }
  43     { "url" "LINK" { VARCHAR 256 } +not-null+ }
  44     { "description" "DESCRIPTION" TEXT +not-null+ }
  45     { "date" "DATE" TIMESTAMP +not-null+ }
  46 } define-persistent
  47
  48 : init-blog-table ( -- ) blog ensure-table ;
  49
  50 : init-postings-table ( -- ) posting ensure-table ;
  51
  52 : <blog> ( id -- todo )
  53     blog new
  54         swap >>id ;
  55
  56 : blogroll ( -- seq )
  57     f <blog> select-tuples
  58     [ [ name>> ] compare ] sort ;
  59
  60 : postings ( -- seq )
  61     posting new select-tuples
  62     [ [ date>> ] compare invert-comparison ] sort ;
  63
  64 : <edit-blogroll-action> ( -- action )
  65     <page-action>
  66         [ blogroll "blogroll" set-value ] >>init
  67         { planet-factor "admin" } >>template ;
  68
  69 : <planet-action> ( -- action )
  70     <page-action>
  71         [
  72             blogroll "blogroll" set-value
  73             postings "postings" set-value
  74         ] >>init
  75
  76         { planet-factor "planet" } >>template ;
  77
  78 : <planet-feed-action> ( -- action )
  79     <feed-action>
  80         [ "Planet Factor" ] >>title
  81         [ URL" $planet-factor" ] >>url
  82         [ postings ] >>entries ;
  83
  84 :: <posting> ( entry name -- entry' )
  85     posting new
  86         name ": " entry title>> 3append >>title
  87         entry url>> >>url
  88         entry description>> >>description
  89         entry date>> >>date ;
  90
  91 : fetch-feed ( url -- feed )
  92     download-feed entries>> ;
  93
  94 \ fetch-feed DEBUG add-error-logging
  95
  96 : fetch-blogroll ( blogroll -- entries )
  97     [ [ feed-url>> fetch-feed ] parallel-map ] [ [ name>> ] map ] bi
  98     [ '[ , <posting> ] map ] 2map concat ;
  99
 100 : sort-entries ( entries -- entries' )
 101     [ [ date>> ] compare invert-comparison ] sort ;
 102
 103 : update-cached-postings ( -- )
 104     blogroll fetch-blogroll sort-entries 8 short head [
 105         posting new delete-tuples
 106         [ insert-tuple ] each
 107     ] with-transaction ;
 108
 109 : <update-action> ( -- action )
 110     <action>
 111         [
 112             update-cached-postings
 113             URL" $planet-factor/admin" <redirect>
 114         ] >>submit ;
 115
 116 : <delete-blog-action> ( -- action )
 117     <action>
 118         [ validate-integer-id ] >>validate
 119
 120         [
 121             "id" value <blog> delete-tuples
 122             URL" $planet-factor/admin" <redirect>
 123         ] >>submit ;
 124
 125 : validate-blog ( -- )
 126     {
 127         { "name" [ v-one-line ] }
 128         { "www-url" [ v-url ] }
 129         { "feed-url" [ v-url ] }
 130     } validate-params ;
 131
 132 : deposit-blog-slots ( blog -- )
 133     { "name" "www-url" "feed-url" } deposit-slots ;
 134
 135 : <new-blog-action> ( -- action )
 136     <page-action>
 137         { planet-factor "new-blog" } >>template
 138
 139         [ validate-blog ] >>validate
 140
 141         [
 142             f <blog>
 143             [ deposit-blog-slots ]
 144             [ insert-tuple ]
 145             [
 146                 <url>
 147                     "$planet-factor/admin/edit-blog" >>path
 148                     swap id>> "id" set-query-param
 149                 <redirect>
 150             ]
 151             tri
 152         ] >>submit ;
 153
 154 : <edit-blog-action> ( -- action )
 155     <page-action>
 156         [
 157             validate-integer-id
 158             "id" value <blog> select-tuple from-object
 159         ] >>init
 160
 161         { planet-factor "edit-blog" } >>template
 162
 163         [
 164             validate-integer-id
 165             validate-blog
 166         ] >>validate
 167
 168         [
 169             f <blog>
 170             [ deposit-blog-slots ]
 171             [ update-tuple ]
 172             [
 173                 <url>
 174                     "$planet-factor/admin" >>path
 175                     swap id>> "id" set-query-param
 176                 <redirect>
 177             ]
 178             tri
 179         ] >>submit ;
 180
 181 : <planet-factor-admin> ( -- responder )
 182     planet-factor-admin new-dispatcher
 183         <edit-blogroll-action> "blogroll" add-main-responder
 184         <update-action> "update" add-responder
 185         <new-blog-action> "new-blog" add-responder
 186         <edit-blog-action> "edit-blog" add-responder
 187         <delete-blog-action> "delete-blog" add-responder ;
 188
 189 SYMBOL: can-administer-planet-factor?
 190
 191 can-administer-planet-factor? define-capability
 192
 193 : <planet-factor> ( -- responder )
 194     planet-factor new-dispatcher
 195         <planet-action> "list" add-main-responder
 196         <planet-feed-action> "feed.xml" add-responder
 197         <planet-factor-admin> <protected>
 198             "administer Planet Factor" >>description
 199             { can-administer-planet-factor? } >>capabilities
 200         "admin" add-responder
 201     <boilerplate>
 202         { planet-factor "planet-common" } >>template ;
 203
 204 : start-update-task ( db params -- )
 205     '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;