extra/webapps/pastebin/pastebin.factor

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