extra/webapps/pastebin/pastebin.factor

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