1 ! Copyright (C) 2008 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel accessors sequences sorting math.order math.parser
4 urls validators db db.types db.tuples calendar present namespaces
7 http.server.dispatchers
17 TUPLE: blogs < dispatcher ;
19 SYMBOL: can-administer-blogs?
21 can-administer-blogs? define-capability
23 : view-post-url ( id -- url )
24 present "$blogs/post/" prepend >url ;
26 : view-comment-url ( parent id -- url )
27 [ view-post-url ] dip >>anchor ;
29 : list-posts-url ( -- url )
32 : posts-by-url ( author -- url )
33 "$blogs/by/" prepend >url ;
35 TUPLE: entity id author date content ;
37 GENERIC: entity-url ( entity -- url )
39 M: entity feed-entry-url entity-url ;
42 { "id" "ID" INTEGER +db-assigned-id+ }
43 { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
44 { "date" "DATE" TIMESTAMP +not-null+ }
45 { "content" "CONTENT" TEXT +not-null+ }
48 M: entity feed-entry-date date>> ;
50 TUPLE: post < entity title comments ;
52 M: post feed-entry-title
53 [ author>> ] [ title>> ] bi ": " swap 3append ;
59 { "title" "TITLE" { VARCHAR 256 } +not-null+ }
62 : <post> ( id -- post ) \ post new swap >>id ;
64 TUPLE: comment < entity parent ;
67 { "parent" "PARENT" INTEGER +not-null+ } ! post id
70 M: comment feed-entry-title
71 author>> "Comment by " prepend ;
74 [ parent>> ] [ id>> ] bi view-comment-url ;
76 : <comment> ( parent id -- post )
82 [ <post> select-tuple ] [ f <comment> select-tuples ] bi
85 : reverse-chronological-order ( seq -- sorted )
86 [ [ date>> ] compare invert-comparison ] sort ;
88 : validate-author ( -- )
89 { { "author" [ v-username ] } } validate-params ;
91 : list-posts ( -- posts )
92 f <post> "author" value >>author
93 select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
94 reverse-chronological-order ;
96 : <list-posts-action> ( -- action )
98 [ list-posts "posts" set-value ] >>init
99 { blogs "list-posts" } >>template ;
101 : <list-posts-feed-action> ( -- action )
103 [ "Recent Posts" ] >>title
104 [ list-posts ] >>entries
105 [ list-posts-url ] >>url ;
107 : <posts-by-action> ( -- action )
114 list-posts "posts" set-value
117 { blogs "posts-by" } >>template ;
119 : <posts-by-feed-action> ( -- action )
122 [ validate-author ] >>init
123 [ "Recent Posts by " "author" value append ] >>title
124 [ list-posts ] >>entries
125 [ "author" value posts-by-url ] >>url ;
127 : <post-feed-action> ( -- action )
130 [ validate-integer-id "id" value post "post" set-value ] >>init
131 [ "post" value feed-entry-title ] >>title
132 [ "post" value entity-url ] >>url
133 [ "post" value comments>> ] >>entries ;
135 : <view-post-action> ( -- action )
142 "id" value post from-object
150 { blogs "view-post" } >>template ;
152 : validate-post ( -- )
154 { "title" [ v-one-line ] }
155 { "content" [ v-required ] }
158 : <new-post-action> ( -- action )
163 logged-in-user get username>> "author" set-value
168 dup { "title" "content" } to-object
169 logged-in-user get username>> >>author
171 [ insert-tuple ] [ entity-url <redirect> ] bi
174 { blogs "new-post" } >>template
177 "make a new blog post" >>description ;
179 : authorize-author ( author -- )
180 logged-in-user get username>> =
181 can-administer-blogs? have-capability? or
182 [ login-required ] unless ;
184 : do-post-action ( -- )
186 "id" value <post> select-tuple from-object ;
188 : <edit-post-action> ( -- action )
193 [ do-post-action ] >>init
195 [ do-post-action validate-post ] >>validate
197 [ "author" value authorize-author ] >>authorize
201 dup { "title" "author" "date" "content" } to-object
202 [ update-tuple ] [ entity-url <redirect> ] bi
205 { blogs "edit-post" } >>template
208 "edit a blog post" >>description ;
210 : delete-post ( id -- )
211 [ <post> delete-tuples ] [ f <comment> delete-tuples ] bi ;
213 : <delete-post-action> ( -- action )
216 [ do-post-action ] >>validate
218 [ "author" value authorize-author ] >>authorize
221 [ "id" value delete-post ] with-transaction
222 "author" value posts-by-url <redirect>
226 "delete a blog post" >>description ;
228 : <delete-author-action> ( -- action )
231 [ validate-author ] >>validate
233 [ "author" value authorize-author ] >>authorize
237 f <post> "author" value >>author select-tuples [ id>> delete-post ] each
238 f f <comment> "author" value >>author delete-tuples
240 "author" value posts-by-url <redirect>
244 "delete a blog post" >>description ;
246 : validate-comment ( -- )
248 { "parent" [ v-integer ] }
249 { "content" [ v-required ] }
252 : <new-comment-action> ( -- action )
257 logged-in-user get username>> "author" set-value
261 "parent" value f <comment>
262 "content" value >>content
263 logged-in-user get username>> >>author
265 [ insert-tuple ] [ entity-url <redirect> ] bi
269 "make a comment" >>description ;
271 : <delete-comment-action> ( -- action )
276 { { "parent" [ v-integer ] } } validate-params
280 "parent" value <post> select-tuple
281 author>> authorize-author
285 f "id" value <comment> delete-tuples
286 "parent" value view-post-url <redirect>
290 "delete a comment" >>description ;
292 : <blogs> ( -- dispatcher )
294 <list-posts-action> "" add-responder
295 <list-posts-feed-action> "posts.atom" add-responder
296 <posts-by-action> "by" add-responder
297 <posts-by-feed-action> "by.atom" add-responder
298 <view-post-action> "post" add-responder
299 <post-feed-action> "post.atom" add-responder
300 <new-post-action> "new-post" add-responder
301 <edit-post-action> "edit-post" add-responder
302 <delete-post-action> "delete-post" add-responder
303 <new-comment-action> "new-comment" add-responder
304 <delete-comment-action> "delete-comment" add-responder
306 { blogs "blogs-common" } >>template ;