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 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             [
 148                 <url>
 149                     "$planet/admin/edit-blog" >>path
 150                     swap id>> "id" set-query-param
 151                 <redirect>
 152             ]
 153             tri
 154         ] >>submit ;
 155
 156 : <edit-blog-action> ( -- action )
 157     <page-action>
 158
 159         [
 160             validate-integer-id
 161             "id" value <blog> select-tuple from-object
 162         ] >>init
 163
 164         { planet "edit-blog" } >>template
 165
 166         [
 167             validate-integer-id
 168             validate-blog
 169         ] >>validate
 170
 171         [
 172             f <blog>
 173             [ deposit-blog-slots ]
 174             [ update-tuple ]
 175             [
 176                 <url>
 177                     "$planet/admin" >>path
 178                     swap id>> "id" set-query-param
 179                 <redirect>
 180             ]
 181             tri
 182         ] >>submit ;
 183
 184 : <planet-admin> ( -- responder )
 185     planet-admin new-dispatcher
 186         <edit-blogroll-action> "blogroll" add-main-responder
 187         <update-action> "update" add-responder
 188         <new-blog-action> "new-blog" add-responder
 189         <edit-blog-action> "edit-blog" add-responder
 190         <delete-blog-action> "delete-blog" add-responder
 191     <protected>
 192         "administer Planet Factor" >>description
 193         { can-administer-planet? } >>capabilities ;
 194
 195 : <planet> ( -- responder )
 196     planet new-dispatcher
 197         <planet-action> "list" add-main-responder
 198         <planet-feed-action> "feed.xml" add-responder
 199         <planet-admin> "admin" add-responder
 200     <boilerplate>
 201         { planet "planet-common" } >>template ;
 202
 203 : start-update-task ( db params -- )
 204     '[ _ _ [ update-cached-postings ] with-db ] 10 minutes every drop ;