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 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 ;
11 TUPLE: pastebin < dispatcher ;
13 SYMBOL: can-delete-pastes?
15 SYMBOL: pastebin-email-from
16 SYMBOL: pastebin-email-to
18 can-delete-pastes? define-capability
24 TUPLE: entity id summary author mode date contents ;
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+ }
36 GENERIC: entity-url ( entity -- url )
38 M: entity feed-entry-title summary>> ;
40 M: entity feed-entry-date date>> ;
42 M: entity feed-entry-url entity-url ;
44 TUPLE: paste-state < entity annotations ;
46 \ paste-state "PASTES" { } define-persistent
48 : <paste-state> ( id -- paste )
52 : pastes ( -- pastes )
53 f <paste-state> select-tuples
57 TUPLE: annotation < entity parent ;
59 \ annotation "ANNOTATIONS"
61 { "parent" "PARENT" INTEGER +not-null+ }
64 : <annotation> ( parent id -- annotation )
69 : lookup-annotation ( id -- annotation )
70 [ f ] dip <annotation> select-tuple ;
72 : paste ( id -- paste/f )
73 [ <paste-state> select-tuple ] keep over [
74 f <annotation> select-tuples >>annotations
81 CONSTANT: pastebin-url URL" $pastebin/"
83 : paste-url ( id -- url )
84 "$pastebin/paste" >url swap "id" set-query-param ;
86 M: paste-state entity-url
89 : annotation-url ( parent id -- url )
90 "$pastebin/paste" >url
91 swap number>string >>anchor
92 swap "id" set-query-param ;
94 M: annotation entity-url
95 [ parent>> ] [ id>> ] bi annotation-url ;
101 : <pastebin-action> ( -- action )
103 [ pastes "pastes" set-value ] >>init
104 { pastebin "pastebin" } >>template ;
106 : <pastebin-feed-action> ( -- action )
108 [ pastebin-url ] >>url
109 [ "Factor Pastebin" ] >>title
110 [ pastes ] >>entries ;
116 : <paste-action> ( -- action )
120 "id" value paste from-object
125 mode-names "modes" set-value
126 "factor" "mode" set-value
130 { pastebin "paste" } >>template ;
132 : <raw-paste-action> ( -- action )
134 [ validate-integer-id "id" value paste from-object ] >>init
135 [ "contents" value <text-content> ] >>display ;
137 : <paste-feed-action> ( -- 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 ;
144 : validate-entity ( -- )
146 { "summary" [ v-one-line ] }
147 { "author" [ v-one-line ] }
148 { "mode" [ v-mode ] }
149 { "contents" [ v-required ] }
153 : deposit-entity-slots ( tuple -- )
155 { "summary" "author" "mode" "contents" } to-object ;
157 : email-on-paste ( url -- )
158 pastebin-email-to get-global [
163 swap adjust-url present >>body
164 pastebin-email-from get-global >>from
165 "New paste!" >>subject
169 : <new-paste-action> ( -- action )
172 "factor" "mode" set-value
173 mode-names "modes" set-value
176 { pastebin "new-paste" } >>template
179 mode-names "modes" set-value
185 [ deposit-entity-slots ]
187 [ id>> paste-url [ email-on-paste ] [ <redirect> ] bi ]
191 : <delete-paste-action> ( -- action )
194 [ validate-integer-id ] >>validate
198 "id" value <paste-state> delete-tuples
199 "id" value f <annotation> delete-tuples
201 pastebin-url <redirect>
205 "delete pastes" >>description
206 { can-delete-pastes? } >>capabilities ;
212 : <new-annotation-action> ( -- action )
215 mode-names "modes" set-value
216 { { "parent" [ v-integer ] } } validate-params
221 "parent" value f <annotation>
222 [ deposit-entity-slots ]
224 [ entity-url <redirect> ]
228 : <raw-annotation-action> ( -- action )
230 [ validate-integer-id "id" value lookup-annotation from-object ] >>init
231 [ "contents" value <text-content> ] >>display ;
233 : <delete-annotation-action> ( -- action )
236 [ { { "id" [ v-number ] } } validate-params ] >>validate
239 "id" value lookup-annotation
241 [ parent>> paste-url <redirect> ]
246 "delete annotations" >>description
247 { can-delete-pastes? } >>capabilities ;
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
262 { pastebin "pastebin-common" } >>template ;