extra/webapps/pastebin/pastebin.factor

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