extra/webapps/pastebin/pastebin.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces assocs sorting sequences kernel accessors
   4 hashtables db.types db.tuples db combinators
   5 calendar calendar.format math.parser math.order syndication urls
   6 xml.writer xmode.catalog validators
   7 html.forms
   8 html.components
   9 html.templates.chloe
  10 http.server
  11 http.server.dispatchers
  12 http.server.redirection
  13 furnace
  14 furnace.actions
  15 furnace.redirection
  16 furnace.auth
  17 furnace.auth.login
  18 furnace.boilerplate
  19 furnace.syndication ;
  20 IN: webapps.pastebin
  21
  22 TUPLE: pastebin < dispatcher ;
  23
  24 SYMBOL: can-delete-pastes?
  25
  26 can-delete-pastes? define-capability
  27
  28 ! ! !
  29 ! DOMAIN MODEL
  30 ! ! !
  31
  32 TUPLE: entity id summary author mode date contents ;
  33
  34 entity f
  35 {
  36     { "id" "ID" INTEGER +db-assigned-id+ }
  37     { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
  38     { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
  39     { "mode" "MODE" { VARCHAR 256 } +not-null+ }
  40     { "date" "DATE" DATETIME +not-null+ }
  41     { "contents" "CONTENTS" TEXT +not-null+ }
  42 } define-persistent
  43
  44 GENERIC: entity-url ( entity -- url )
  45
  46 M: entity feed-entry-title summary>> ;
  47
  48 M: entity feed-entry-date date>> ;
  49
  50 M: entity feed-entry-url entity-url ;
  51
  52 TUPLE: paste < entity annotations ;
  53
  54 \ paste "PASTES" { } define-persistent
  55
  56 : <paste> ( id -- paste )
  57     \ paste new
  58         swap >>id ;
  59
  60 : pastes ( -- pastes )
  61     f <paste> select-tuples
  62     [ date>> ] sort-with
  63     reverse ;
  64
  65 TUPLE: annotation < entity parent ;
  66
  67 annotation "ANNOTATIONS"
  68 {
  69     { "parent" "PARENT" INTEGER +not-null+ }
  70 } define-persistent
  71
  72 : <annotation> ( parent id -- annotation )
  73     annotation new
  74         swap >>id
  75         swap >>parent ;
  76
  77 : paste ( id -- paste )
  78     [ <paste> select-tuple ]
  79     [ f <annotation> select-tuples ]
  80     bi >>annotations ;
  81
  82 ! ! !
  83 ! LINKS, ETC
  84 ! ! !
  85
  86 CONSTANT: pastebin-url URL" $pastebin/"
  87
  88 : paste-url ( id -- url )
  89     "$pastebin/paste" >url swap "id" set-query-param ;
  90
  91 M: paste entity-url
  92     id>> paste-url ;
  93
  94 : annotation-url ( parent id -- url )
  95     "$pastebin/paste" >url
  96         swap number>string >>anchor
  97         swap "id" set-query-param ;
  98
  99 M: annotation entity-url
 100     [ parent>> ] [ id>> ] bi annotation-url ;
 101
 102 ! ! !
 103 ! PASTE LIST
 104 ! ! !
 105
 106 : <pastebin-action> ( -- action )
 107     <page-action>
 108         [ pastes "pastes" set-value ] >>init
 109         { pastebin "pastebin" } >>template ;
 110
 111 : <pastebin-feed-action> ( -- action )
 112     <feed-action>
 113         [ pastebin-url ] >>url
 114         [ "Factor Pastebin" ] >>title
 115         [ pastes ] >>entries ;
 116
 117 ! ! !
 118 ! PASTES
 119 ! ! !
 120
 121 : <paste-action> ( -- action )
 122     <page-action>
 123         [
 124             validate-integer-id
 125             "id" value paste from-object
 126
 127             "id" value
 128             "new-annotation" [
 129                 "parent" set-value
 130                 mode-names "modes" set-value
 131                 "factor" "mode" set-value
 132             ] nest-form
 133         ] >>init
 134
 135         { pastebin "paste" } >>template ;
 136
 137 : <paste-feed-action> ( -- action )
 138     <feed-action>
 139         [ validate-integer-id ] >>init
 140         [ "id" value paste-url ] >>url
 141         [ "Paste " "id" value number>string append ] >>title
 142         [ "id" value f <annotation> select-tuples ] >>entries ;
 143
 144 : validate-entity ( -- )
 145     {
 146         { "summary" [ v-one-line ] }
 147         { "author" [ v-one-line ] }
 148         { "mode" [ v-mode ] }
 149         { "contents" [ v-required ] }
 150         { "captcha" [ v-captcha ] }
 151     } validate-params ;
 152
 153 : deposit-entity-slots ( tuple -- )
 154     now >>date
 155     { "summary" "author" "mode" "contents" } to-object ;
 156
 157 : <new-paste-action> ( -- action )
 158     <page-action>
 159         [
 160             "factor" "mode" set-value
 161             mode-names "modes" set-value
 162         ] >>init
 163
 164         { pastebin "new-paste" } >>template
 165
 166         [
 167             mode-names "modes" set-value
 168             validate-entity
 169         ] >>validate
 170
 171         [
 172             f <paste>
 173             [ deposit-entity-slots ]
 174             [ insert-tuple ]
 175             [ id>> paste-url <redirect> ]
 176             tri
 177         ] >>submit ;
 178
 179 : <delete-paste-action> ( -- action )
 180     <action>
 181
 182         [ validate-integer-id ] >>validate
 183
 184         [
 185             [
 186                 "id" value <paste> delete-tuples
 187                 "id" value f <annotation> delete-tuples
 188             ] with-transaction
 189             pastebin-url <redirect>
 190         ] >>submit
 191
 192         <protected>
 193             "delete pastes" >>description
 194             { can-delete-pastes? } >>capabilities ;
 195
 196 ! ! !
 197 ! ANNOTATIONS
 198 ! ! !
 199
 200 : <new-annotation-action> ( -- action )
 201     <action>
 202         [
 203             mode-names "modes" set-value
 204             { { "parent" [ v-integer ] } } validate-params
 205             validate-entity
 206         ] >>validate
 207
 208         [
 209             "parent" value f <annotation>
 210             [ deposit-entity-slots ]
 211             [ insert-tuple ]
 212             [ entity-url <redirect> ]
 213             tri
 214         ] >>submit ;
 215
 216 : <delete-annotation-action> ( -- action )
 217     <action>
 218
 219         [ { { "id" [ v-number ] } } validate-params ] >>validate
 220
 221         [
 222             f "id" value <annotation> select-tuple
 223             [ delete-tuples ]
 224             [ parent>> paste-url <redirect> ]
 225             bi
 226         ] >>submit
 227
 228     <protected>
 229         "delete annotations" >>description
 230         { can-delete-pastes? } >>capabilities ;
 231
 232 : <pastebin> ( -- responder )
 233     pastebin new-dispatcher
 234         <pastebin-action> "" add-responder
 235         <pastebin-feed-action> "list.atom" add-responder
 236         <paste-action> "paste" add-responder
 237         <paste-feed-action> "paste.atom" add-responder
 238         <new-paste-action> "new-paste" add-responder
 239         <delete-paste-action> "delete-paste" add-responder
 240         <new-annotation-action> "new-annotation" add-responder
 241         <delete-annotation-action> "delete-annotation" add-responder
 242     <boilerplate>
 243         { pastebin "pastebin-common" } >>template ;