extra/webapps/blogs/blogs.factor

   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 html.components db.types db.tuples calendar
   5 http.server.dispatchers
   6 furnace furnace.actions furnace.auth.login furnace.boilerplate
   7 furnace.sessions furnace.syndication ;
   8 IN: webapps.blogs
   9
  10 TUPLE: blogs < dispatcher ;
  11
  12 : view-post-url ( id -- url )
  13     number>string "$blogs/post/" prepend >url ;
  14
  15 : view-comment-url ( parent id -- url )
  16     [ view-post-url ] dip >>anchor ;
  17
  18 : list-posts-url ( -- url )
  19     URL" $blogs/" ;
  20
  21 : user-posts-url ( author -- url )
  22     "$blogs/by/" prepend >url ;
  23
  24 TUPLE: entity id author date content ;
  25
  26 GENERIC: entity-url ( entity -- url )
  27
  28 M: entity feed-entry-url entity-url ;
  29
  30 entity f {
  31     { "id" "ID" INTEGER +db-assigned-id+ }
  32     { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
  33     { "date" "DATE" TIMESTAMP +not-null+ }
  34     { "content" "CONTENT" TEXT +not-null+ }
  35 } define-persistent
  36
  37 M: entity feed-entry-date date>> ;
  38
  39 TUPLE: post < entity title comments ;
  40
  41 M: post feed-entry-title
  42     [ author>> ] [ drop ": " ] [ title>> ] tri 3append ;
  43
  44 M: post entity-url
  45     id>> view-post-url ;
  46
  47 \ post "BLOG_POSTS" {
  48     { "title" "TITLE" { VARCHAR 256 } +not-null+ }
  49 } define-persistent
  50
  51 : <post> ( id -- post ) \ post new swap >>id ;
  52
  53 : init-posts-table ( -- ) \ post ensure-table ;
  54
  55 TUPLE: comment < entity parent ;
  56
  57 comment "COMMENTS" {
  58     { "parent" "PARENT" INTEGER +not-null+ } ! post id
  59 } define-persistent
  60
  61 M: comment feed-entry-title
  62     author>> "Comment by " prepend ;
  63
  64 M: comment entity-url
  65     [ parent>> ] [ id>> ] bi view-comment-url ;
  66
  67 : <comment> ( parent id -- post )
  68     comment new
  69         swap >>id
  70         swap >>parent ;
  71
  72 : init-comments-table ( -- ) comment ensure-table ;
  73
  74 : post ( id -- post )
  75     [ <post> select-tuple ] [ f <comment> select-tuples ] bi
  76     >>comments ;
  77
  78 : reverse-chronological-order ( seq -- sorted )
  79     [ [ date>> ] compare invert-comparison ] sort ;
  80
  81 : validate-author ( -- )
  82     { { "author" [ [ v-username ] v-optional ] } } validate-params ;
  83
  84 : list-posts ( -- posts )
  85     f <post> "author" value >>author
  86     select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
  87     reverse-chronological-order ;
  88
  89 : <list-posts-action> ( -- action )
  90     <page-action>
  91         [
  92             list-posts "posts" set-value
  93         ] >>init
  94
  95         { blogs "list-posts" } >>template ;
  96
  97 : <list-posts-feed-action> ( -- action )
  98     <feed-action>
  99         [ "Recent Posts" ] >>title
 100         [ list-posts ] >>entries
 101         [ list-posts-url ] >>url ;
 102
 103 : <user-posts-action> ( -- action )
 104     <page-action>
 105         "author" >>rest
 106         [
 107             validate-author
 108             list-posts "posts" set-value
 109         ] >>init
 110         { blogs "user-posts" } >>template ;
 111
 112 : <user-posts-feed-action> ( -- action )
 113     <feed-action>
 114         [ validate-author ] >>init
 115         [ "Recent Posts by " "author" value append ] >>title
 116         [ list-posts ] >>entries
 117         [ "author" value user-posts-url ] >>url ;
 118
 119 : <post-feed-action> ( -- action )
 120     <feed-action>
 121         [ validate-integer-id "id" value post "post" set-value ] >>init
 122         [ "post" value feed-entry-title ] >>title
 123         [ "post" value entity-url ] >>url
 124         [ "post" value comments>> ] >>entries ;
 125
 126 : <view-post-action> ( -- action )
 127     <page-action>
 128         "id" >>rest
 129
 130         [
 131             validate-integer-id
 132             "id" value post from-object
 133
 134             "id" value
 135             "new-comment" [
 136                 "parent" set-value
 137             ] nest-values
 138         ] >>init
 139
 140         { blogs "view-post" } >>template ;
 141
 142 : validate-post ( -- )
 143     {
 144         { "title" [ v-one-line ] }
 145         { "content" [ v-required ] }
 146     } validate-params ;
 147
 148 : <new-post-action> ( -- action )
 149     <page-action>
 150         [
 151             validate-post
 152             uid "author" set-value
 153         ] >>validate
 154
 155         [
 156             f <post>
 157                 dup { "title" "content" } deposit-slots
 158                 uid >>author
 159                 now >>date
 160             [ insert-tuple ] [ entity-url <redirect> ] bi
 161         ] >>submit
 162
 163         { blogs "new-post" } >>template ;
 164
 165 : <edit-post-action> ( -- action )
 166     <page-action>
 167         [
 168             validate-integer-id
 169             "id" value <post> select-tuple from-object
 170         ] >>init
 171
 172         [
 173             validate-integer-id
 174             validate-post
 175         ] >>validate
 176
 177         [
 178             "id" value <post> select-tuple
 179                 dup { "title" "content" } deposit-slots
 180             [ update-tuple ] [ entity-url <redirect> ] bi
 181         ] >>submit
 182
 183         { blogs "edit-post" } >>template ;
 184
 185 : <delete-post-action> ( -- action )
 186     <action>
 187         [
 188             validate-integer-id
 189             { { "author" [ v-username ] } } validate-params
 190         ] >>validate
 191         [
 192             "id" value <post> delete-tuples
 193             "author" value user-posts-url <redirect>
 194         ] >>submit ;
 195
 196 : validate-comment ( -- )
 197     {
 198         { "parent" [ v-integer ] }
 199         { "content" [ v-required ] }
 200     } validate-params ;
 201
 202 : <new-comment-action> ( -- action )
 203     <action>
 204
 205         [
 206             validate-comment
 207             uid "author" set-value
 208         ] >>validate
 209
 210         [
 211             "parent" value f <comment>
 212                 "content" value >>content
 213                 uid >>author
 214                 now >>date
 215             [ insert-tuple ] [ entity-url <redirect> ] bi
 216         ] >>submit ;
 217
 218 : <delete-comment-action> ( -- action )
 219     <action>
 220         [
 221             validate-integer-id
 222             { { "parent" [ v-integer ] } } validate-params
 223         ] >>validate
 224         [
 225             f "id" value <comment> delete-tuples
 226             "parent" value view-post-url <redirect>
 227         ] >>submit ;
 228
 229 : <blogs> ( -- dispatcher )
 230     blogs new-dispatcher
 231         <list-posts-action> "" add-responder
 232         <list-posts-feed-action> "posts.atom" add-responder
 233         <user-posts-action> "by" add-responder
 234         <user-posts-feed-action> "by.atom" add-responder
 235         <view-post-action> "post" add-responder
 236         <post-feed-action> "post.atom" add-responder
 237         <new-post-action> <protected>
 238             "make a new blog post" >>description
 239             "new-post" add-responder
 240         <edit-post-action> <protected>
 241             "edit a blog post" >>description
 242             "edit-post" add-responder
 243         <delete-post-action> <protected>
 244             "delete a blog post" >>description
 245             "delete-post" add-responder
 246         <new-comment-action> <protected>
 247             "make a comment" >>description
 248             "new-comment" add-responder
 249         <delete-comment-action> <protected>
 250             "delete a comment" >>description
 251             "delete-comment" add-responder
 252     <boilerplate>
 253         { blogs "blogs-common" } >>template ;