extra/webapps/blogs/blogs.factor

   1 ! Copyright (C) 2008 Slava Pestov
   2 ! See https://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
   5 html.forms
   6 html.components
   7 http.server.dispatchers
   8 furnace
   9 furnace.actions
  10 furnace.redirection
  11 furnace.auth
  12 furnace.auth.login
  13 furnace.boilerplate
  14 furnace.syndication ;
  15 IN: webapps.blogs
  16
  17 TUPLE: blogs < dispatcher ;
  18
  19 SYMBOL: can-administer-blogs?
  20
  21 can-administer-blogs? define-capability
  22
  23 : view-post-url ( id -- url )
  24     present "$blogs/post/" prepend >url ;
  25
  26 : view-comment-url ( parent id -- url )
  27     [ view-post-url ] dip >>anchor ;
  28
  29 : list-posts-url ( -- url )
  30     "$blogs/" >url ;
  31
  32 : posts-by-url ( author -- url )
  33     "$blogs/by/" prepend >url ;
  34
  35 TUPLE: entity id author date content ;
  36
  37 GENERIC: entity-url ( entity -- url )
  38
  39 M: entity feed-entry-url entity-url ;
  40
  41 entity f {
  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+ }
  46 } define-persistent
  47
  48 M: entity feed-entry-date date>> ;
  49
  50 TUPLE: post-state < entity title comments ;
  51
  52 M: post-state feed-entry-title
  53     [ author>> ] [ title>> ] bi ": " glue ;
  54
  55 M: post-state entity-url
  56     id>> view-post-url ;
  57
  58 \ post-state "BLOG_POSTS" {
  59     { "title" "TITLE" { VARCHAR 256 } +not-null+ }
  60 } define-persistent
  61
  62 : <post-state> ( id -- post ) \ post-state new swap >>id ;
  63
  64 TUPLE: comment < entity parent ;
  65
  66 comment "COMMENTS" {
  67     { "parent" "PARENT" INTEGER +not-null+ } ! post id
  68 } define-persistent
  69
  70 M: comment feed-entry-title
  71     author>> "Comment by " prepend ;
  72
  73 M: comment entity-url
  74     [ parent>> ] [ id>> ] bi view-comment-url ;
  75
  76 : <comment> ( parent id -- post )
  77     comment new
  78         swap >>id
  79         swap >>parent ;
  80
  81 : post ( id -- post )
  82     [ <post-state> select-tuple ] [ f <comment> select-tuples ] bi
  83     >>comments ;
  84
  85 : reverse-chronological-order ( seq -- sorted )
  86     [ date>> ] inv-sort-by ;
  87
  88 : validate-author ( -- )
  89     { { "author" [ v-username ] } } validate-params ;
  90
  91 : list-posts ( -- posts )
  92     f <post-state> "author" value >>author
  93     select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
  94     reverse-chronological-order ;
  95
  96 : <list-posts-action> ( -- action )
  97     <page-action>
  98         [ list-posts "posts" set-value ] >>init
  99         { blogs "list-posts" } >>template ;
 100
 101 : <list-posts-feed-action> ( -- action )
 102     <feed-action>
 103         [ "Recent Posts" ] >>title
 104         [ list-posts ] >>entries
 105         [ list-posts-url ] >>url ;
 106
 107 : <posts-by-action> ( -- action )
 108     <page-action>
 109
 110         "author" >>rest
 111
 112         [
 113             validate-author
 114             list-posts "posts" set-value
 115         ] >>init
 116
 117         { blogs "posts-by" } >>template ;
 118
 119 : <posts-by-feed-action> ( -- action )
 120     <feed-action>
 121         "author" >>rest
 122         [ validate-author ] >>init
 123         [ "Recent Posts by " "author" value append ] >>title
 124         [ list-posts ] >>entries
 125         [ "author" value posts-by-url ] >>url ;
 126
 127 : <post-feed-action> ( -- action )
 128     <feed-action>
 129         "id" >>rest
 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 ;
 134
 135 : <view-post-action> ( -- action )
 136     <page-action>
 137
 138         "id" >>rest
 139
 140         [
 141             validate-integer-id
 142             "id" value post from-object
 143
 144             "id" value
 145             "new-comment" [
 146                 "parent" set-value
 147             ] nest-form
 148         ] >>init
 149
 150         { blogs "view-post" } >>template ;
 151
 152 : validate-post ( -- )
 153     {
 154         { "title" [ v-one-line ] }
 155         { "content" [ v-required ] }
 156     } validate-params ;
 157
 158 : <new-post-action> ( -- action )
 159     <page-action>
 160
 161         [
 162             validate-post
 163             username "author" set-value
 164         ] >>validate
 165
 166         [
 167             f <post-state>
 168                 dup { "title" "content" } to-object
 169                 username >>author
 170                 now >>date
 171             [ insert-tuple ] [ entity-url <redirect> ] bi
 172         ] >>submit
 173
 174         { blogs "new-post" } >>template
 175
 176     <protected>
 177         "make a new blog post" >>description ;
 178
 179 : authorize-author ( author -- )
 180     username =
 181     { can-administer-blogs? } have-capabilities? or
 182     [ "edit a blog post" f login-required ] unless ;
 183
 184 : do-post-action ( -- )
 185     validate-integer-id
 186     "id" value <post-state> select-tuple from-object ;
 187
 188 : <edit-post-action> ( -- action )
 189     <page-action>
 190
 191         "id" >>rest
 192
 193         [ do-post-action ] >>init
 194
 195         [ do-post-action validate-post ] >>validate
 196
 197         [ "author" value authorize-author ] >>authorize
 198
 199         [
 200             "id" value <post-state>
 201             dup { "title" "author" "date" "content" } to-object
 202             [ update-tuple ] [ entity-url <redirect> ] bi
 203         ] >>submit
 204
 205         { blogs "edit-post" } >>template
 206
 207     <protected>
 208         "edit a blog post" >>description ;
 209
 210 : delete-post ( id -- )
 211     [ <post-state> delete-tuples ] [ f <comment> delete-tuples ] bi ;
 212
 213 : <delete-post-action> ( -- action )
 214     <action>
 215
 216         [ do-post-action ] >>validate
 217
 218         [ "author" value authorize-author ] >>authorize
 219
 220         [
 221             [ "id" value delete-post ] with-transaction
 222             "author" value posts-by-url <redirect>
 223         ] >>submit
 224
 225     <protected>
 226         "delete a blog post" >>description ;
 227
 228 : <delete-author-action> ( -- action )
 229     <action>
 230
 231         [ validate-author ] >>validate
 232
 233         [ "author" value authorize-author ] >>authorize
 234
 235         [
 236             [
 237                 f <post-state> "author" value >>author select-tuples [ id>> delete-post ] each
 238                 f f <comment> "author" value >>author delete-tuples
 239             ] with-transaction
 240             "author" value posts-by-url <redirect>
 241         ] >>submit
 242
 243     <protected>
 244         "delete a blog post" >>description ;
 245
 246 : validate-comment ( -- )
 247     {
 248         { "parent" [ v-integer ] }
 249         { "content" [ v-required ] }
 250     } validate-params ;
 251
 252 : <new-comment-action> ( -- action )
 253     <action>
 254
 255         [
 256             validate-comment
 257             username "author" set-value
 258         ] >>validate
 259
 260         [
 261             "parent" value f <comment>
 262                 "content" value >>content
 263                 username >>author
 264                 now >>date
 265             [ insert-tuple ] [ entity-url <redirect> ] bi
 266         ] >>submit
 267
 268     <protected>
 269         "make a comment" >>description ;
 270
 271 : <delete-comment-action> ( -- action )
 272     <action>
 273
 274         [
 275             validate-integer-id
 276             { { "parent" [ v-integer ] } } validate-params
 277         ] >>validate
 278
 279         [
 280             "parent" value <post-state> select-tuple
 281             author>> authorize-author
 282         ] >>authorize
 283
 284         [
 285             f "id" value <comment> delete-tuples
 286             "parent" value view-post-url <redirect>
 287         ] >>submit
 288
 289         <protected>
 290             "delete a comment" >>description ;
 291
 292 : <blogs> ( -- dispatcher )
 293     blogs new-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
 305     <boilerplate>
 306         { blogs "blogs-common" } >>template ;