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
11 TUPLE: planet < dispatcher ;
13 SYMBOL: can-administer-planet?
15 can-administer-planet? define-capability
17 TUPLE: planet-admin < dispatcher ;
19 TUPLE: blog id name www-url feed-url ;
21 M: blog link-title name>> ;
23 M: blog link-href www-url>> ;
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+ }
33 TUPLE: posting < entry id ;
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+ }
44 : <blog> ( id -- todo )
49 f <blog> select-tuples
50 [ name>> ] sort-with ;
53 posting new select-tuples
54 [ date>> ] inv-sort-with ;
56 : <edit-blogroll-action> ( -- action )
58 [ blogroll "blogroll" set-value ] >>init
59 { planet "admin" } >>template ;
61 : <planet-action> ( -- action )
64 blogroll "blogroll" set-value
65 postings "postings" set-value
68 { planet "planet" } >>template ;
70 : <planet-feed-action> ( -- action )
72 [ "Planet Factor" ] >>title
73 [ URL" $planet" ] >>url
74 [ postings ] >>entries ;
76 :: <posting> ( entry name -- entry' )
78 name ": " entry title>> 3append >>title
80 entry description>> >>description
83 : fetch-feed ( url -- feed )
84 download-feed entries>> ;
86 \ fetch-feed DEBUG add-error-logging
88 : fetch-blogroll ( blogroll -- entries )
89 [ [ feed-url>> fetch-feed ] parallel-map ] [ [ name>> ] map ] bi
90 [ '[ _ <posting> ] map ] 2map concat ;
92 : sort-entries ( entries -- entries' )
93 [ date>> ] inv-sort-with ;
95 : update-cached-postings ( -- )
96 blogroll fetch-blogroll sort-entries 8 cramp head [
97 posting new delete-tuples
101 : <update-action> ( -- action )
104 update-cached-postings
105 URL" $planet/admin" <redirect>
108 : <delete-blog-action> ( -- action )
110 [ validate-integer-id ] >>validate
113 "id" value <blog> delete-tuples
114 URL" $planet/admin" <redirect>
117 : validate-blog ( -- )
119 { "name" [ v-one-line ] }
120 { "www-url" [ v-url ] }
121 { "feed-url" [ v-url ] }
124 : deposit-blog-slots ( blog -- )
125 { "name" "www-url" "feed-url" } to-object ;
127 : <new-blog-action> ( -- action )
130 { planet "new-blog" } >>template
132 [ validate-blog ] >>validate
136 [ deposit-blog-slots ]
139 URL" $planet/admin" <redirect>
142 : <edit-blog-action> ( -- action )
147 "id" value <blog> select-tuple from-object
150 { planet "edit-blog" } >>template
159 [ deposit-blog-slots ]
160 [ "id" value >>id update-tuple ] bi
163 "$planet/admin" >>path
164 "id" value "id" set-query-param
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
176 "administer Planet Factor" >>description
177 { can-administer-planet? } >>capabilities ;
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
186 { planet "planet-common" } >>template ;
188 : start-update-task ( db -- )
191 [ _ [ update-cached-postings ] with-db ] with-logging
192 ] 10 minutes every drop ;