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 sequences.lib db.types db.tuples db combinators
   5 calendar calendar.format math.parser syndication urls xml.writer
   6 xmode.catalog validators
   7 html.components
   8 html.templates.chloe
   9 http.server
  10 http.server.dispatchers
  11 http.server.redirection
  12 furnace
  13 furnace.actions
  14 furnace.auth
  15 furnace.auth.login
  16 furnace.boilerplate
  17 furnace.syndication ;
  18 IN: webapps.pastebin
  19
  20 TUPLE: pastebin < dispatcher ;
  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 < entity annotations ;
  47
  48 \ paste "PASTES" { } define-persistent
  49
  50 : <paste> ( id -- paste )
  51     \ paste new
  52         swap >>id ;
  53
  54 : pastes ( -- pastes )
  55     f <paste> select-tuples ;
  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 : paste ( id -- paste )
  70     [ <paste> select-tuple ]
  71     [ f <annotation> select-tuples ]
  72     bi >>annotations ;
  73
  74 ! ! !
  75 ! LINKS, ETC
  76 ! ! !
  77
  78 : pastebin-url ( -- url )
  79     URL" $pastebin/list" ;
  80
  81 : paste-url ( id -- url )
  82     "$pastebin/paste" >url swap "id" set-query-param ;
  83
  84 M: paste entity-url
  85     id>> paste-url ;
  86
  87 : annotation-url ( parent id -- url )
  88     "$pastebin/paste" >url
  89         swap number>string >>anchor
  90         swap "id" set-query-param ;
  91
  92 M: annotation entity-url
  93     [ parent>> ] [ id>> ] bi annotation-url ;
  94
  95 ! ! !
  96 ! PASTE LIST
  97 ! ! !
  98
  99 : <pastebin-action> ( -- action )
 100     <page-action>
 101         [ pastes "pastes" set-value ] >>init
 102         { pastebin "pastebin" } >>template ;
 103
 104 : <pastebin-feed-action> ( -- action )
 105     <feed-action>
 106         [ pastebin-url ] >>url
 107         [ "Factor Pastebin" ] >>title
 108         [ pastes <reversed> ] >>entries ;
 109
 110 ! ! !
 111 ! PASTES
 112 ! ! !
 113
 114 : <paste-action> ( -- action )
 115     <page-action>
 116         [
 117             validate-integer-id
 118             "id" value paste from-object
 119
 120             "id" value
 121             "new-annotation" [
 122                 "parent" set-value
 123                 mode-names "modes" set-value
 124                 "factor" "mode" set-value
 125             ] nest-values
 126         ] >>init
 127
 128         { pastebin "paste" } >>template ;
 129
 130 : <paste-feed-action> ( -- action )
 131     <feed-action>
 132         [ validate-integer-id ] >>init
 133         [ "id" value paste-url ] >>url
 134         [ "Paste " "id" value number>string append ] >>title
 135         [ "id" value f <annotation> select-tuples ] >>entries ;
 136
 137 : validate-entity ( -- )
 138     {
 139         { "summary" [ v-one-line ] }
 140         { "author" [ v-one-line ] }
 141         { "mode" [ v-mode ] }
 142         { "contents" [ v-required ] }
 143         { "captcha" [ v-captcha ] }
 144     } validate-params ;
 145
 146 : deposit-entity-slots ( tuple -- )
 147     now >>date
 148     { "summary" "author" "mode" "contents" } deposit-slots ;
 149
 150 : <new-paste-action> ( -- action )
 151     <page-action>
 152         [
 153             "factor" "mode" set-value
 154             mode-names "modes" set-value
 155         ] >>init
 156
 157         { pastebin "new-paste" } >>template
 158
 159         [ mode-names "modes" set-value ] >>validate
 160
 161         [
 162             validate-entity
 163
 164             f <paste>
 165             [ deposit-entity-slots ]
 166             [ insert-tuple ]
 167             [ id>> paste-url <redirect> ]
 168             tri
 169         ] >>submit ;
 170
 171 : <delete-paste-action> ( -- action )
 172     <action>
 173         [ validate-integer-id ] >>validate
 174
 175         [
 176             "id" value <paste> delete-tuples
 177             "id" value f <annotation> delete-tuples
 178             URL" $pastebin/list" <redirect>
 179         ] >>submit ;
 180
 181 ! ! !
 182 ! ANNOTATIONS
 183 ! ! !
 184
 185 : <new-annotation-action> ( -- action )
 186     <action>
 187         [
 188             { { "parent" [ v-integer ] } } validate-params
 189             validate-entity
 190         ] >>validate
 191
 192         [
 193             "parent" value f <annotation>
 194             [ deposit-entity-slots ]
 195             [ insert-tuple ]
 196             [ entity-url <redirect> ]
 197             tri
 198         ] >>submit ;
 199
 200 : <delete-annotation-action> ( -- action )
 201     <action>
 202         [ { { "id" [ v-number ] } } validate-params ] >>validate
 203
 204         [
 205             f "id" value <annotation> select-tuple
 206             [ delete-tuples ]
 207             [ parent>> paste-url <redirect> ]
 208             bi
 209         ] >>submit ;
 210
 211 SYMBOL: can-delete-pastes?
 212
 213 can-delete-pastes? define-capability
 214
 215 : <pastebin> ( -- responder )
 216     pastebin new-dispatcher
 217         <pastebin-action> "list" add-main-responder
 218         <pastebin-feed-action> "list.atom" add-responder
 219         <paste-action> "paste" add-responder
 220         <paste-feed-action> "paste.atom" add-responder
 221         <new-paste-action> "new-paste" add-responder
 222         <delete-paste-action> <protected>
 223             "delete pastes" >>description
 224             { can-delete-pastes? } >>capabilities "delete-paste" add-responder
 225         <new-annotation-action> "new-annotation" add-responder
 226         <delete-annotation-action> <protected>
 227             "delete annotations" >>description
 228             { can-delete-pastes? } >>capabilities "delete-annotation" add-responder
 229     <boilerplate>
 230         { pastebin "pastebin-common" } >>template ;
 231
 232 : init-pastes-table ( -- ) \ paste ensure-table ;
 233
 234 : init-annotations-table ( -- ) annotation ensure-table ;