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