extra/webapps/pastebin/pastebin.factor

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