extra/webapps/planet/planet.factor

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