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