Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 387 lines (347 sloc) 14.659 kB
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
1 (module pastiche (pastiche)
2
3 (import chicken scheme)
4
5 (use awful
6 colorize
7 html-utils
28f34d9 @ckeen Strip html tags from IRC notifications
authored
8 html-parser
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
9 html-tags
10 miscmacros
11 simple-sha1
12 sql-de-lite
13 spiffy
14 tcp
15 awful-sql-de-lite
16 sql-de-lite
17 files
18 posix
19 data-structures
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
20 utils
21 extras
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
22 (srfi 1 13))
23
24
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
25 ;;;
26 ;;; Captchas
27 ;;;
28 (define-record captcha string figlet)
29
30 (define (create-captchas num #!key (min-captcha-len 4) (max-captcha-len 8))
31 ;; returns an alist mapping captcha hashes to captcha records
32
33 (define chars '#(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
34 #\n #\o #\p #\q #\r #\s #\t #\u #\v #\x #\y #\z))
35
36 (define random-captcha
37 (let ((chars-len (vector-length chars)))
38 (lambda ()
39 (list->string
40 (let loop ((n (+ min-captcha-len
41 (random (- max-captcha-len
42 min-captcha-len)))))
43 (if (zero? n)
44 '()
45 (cons (vector-ref chars (random chars-len))
46 (loop (- n 1)))))))))
47
48 (define (figlet str)
49 (call-with-input-pipe (string-append "figlet " str) read-all))
50
51 (let loop ((n (sub1 num)))
52 (if (zero? n)
53 '()
54 (let ((captcha-string (random-captcha)))
55 (cons
56 (cons (string->sha1sum captcha-string)
57 (make-captcha captcha-string
58 (figlet captcha-string)))
59 (loop (- n 1)))))))
60
61 (define (get-captcha captchas)
62 (list-ref captchas (random (length captchas))))
63
64
65 ;;;
66 ;;; Pastiche
67 ;;;
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
68 (define (pastiche base-path db-file
69 #!key (vandusen-port 22722)
ba56d21 @ckeen Add vandusen-host and base-url as parameter
authored
70 (vandusen-host "localhost")
71 (base-url "http://paste.call-cc.org")
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
72 (use-captcha? #t)
73 (num-captchas 500)
323fedb @ckeen Added browsing page
authored
74 (browsing-steps 15)
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
75 (awful-settings (lambda (_) (_))))
76
77 (parameterize ((app-root-path base-path))
78
323fedb @ckeen Added browsing page
authored
79 (add-request-handler-hook!
80 'awful-paste
81 (lambda (path handler)
82 (when (string-prefix? base-path path)
83 (switch-to-sql-de-lite-database)
84 (parameterize ((app-root-path base-path)
85 (db-credentials db-file)
86 (page-css "http://wiki.call-cc.org/chicken.css"))
87 (awful-settings handler)))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
88
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
89 (define figlet-installed?
90 (handle-exceptions exn
91 #f
92 (system* "figlet -v 2>&1 > /dev/null")))
93
94 (when (and use-captcha? (not figlet-installed?))
95 (print "WARNING: `use-captcha?' indicates that captchas are enabled but figlet "
96 "doesn't seem to be installed. Disabling captchas.")
97 (set! use-captcha? #f))
98
9d5df2d @ckeen Move captcha down in form, no link to main menu on bail-out, check for
authored
99 (define captchas (and use-captcha? (create-captchas num-captchas)))
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
100
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
101 ;; The database needs to be initialised once
102 (unless (file-exists? db-file)
103 (let ((db (open-database db-file)))
104 (exec (sql db "create table pastes(hash text, author text, title text, time float, paste text)"))
105 (close-database db)))
106
107 (define (notify nick title url)
ba56d21 @ckeen Add vandusen-host and base-url as parameter
authored
108 (when vandusen-host
28f34d9 @ckeen Strip html tags from IRC notifications
authored
109 (let ((cleaned-nick (with-input-from-string nick html-strip))
110 (cleaned-title (with-input-from-string title html-strip)))
ba56d21 @ckeen Add vandusen-host and base-url as parameter
authored
111 (ignore-errors
b151898 @ckeen Avoid double slash with make-pathname
authored
112 (let ((stuff (sprintf "#chicken ~s pasted ~s ~a"
28f34d9 @ckeen Strip html tags from IRC notifications
authored
113 cleaned-nick cleaned-title (make-pathname base-url url))))
ba56d21 @ckeen Add vandusen-host and base-url as parameter
authored
114 (let-values (((i o) (tcp-connect vandusen-host vandusen-port)))
115 (display stuff o)
116 (newline o)
117 (close-input-port i)
28f34d9 @ckeen Strip html tags from IRC notifications
authored
118 (close-output-port o)))))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
119
a33b827 @ckeen only show "real" pastes on browsing tab, thanks to Peter Bex
authored
120 ; old "select * from pastes order by time desc limit ?,?"
323fedb @ckeen Added browsing page
authored
121 (define (fetch-last-pastes from to)
a33b827 @ckeen only show "real" pastes on browsing tab, thanks to Peter Bex
authored
122 (let ((r ($db "select * from pastes p where time = (select min(time) from pastes p2 where p2.hash=p.hash) order by time desc limit ?,?" values: (list from to))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
123 r))
124
323fedb @ckeen Added browsing page
authored
125 (define (make-post-table n #!optional (from 0))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
126 (define (format-row r)
127 (list (second r) ; Nickname
128 (link (make-pathname base-path (string-append "/paste?id=" (first r)))
129 (third r)) ; title
af2b0f1 @ckeen Added prettify-time for nicer display of the date.
authored
130 (prettify-time (fourth r)))) ;date
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
131
132 (<div> class: "paste-table"
133 (or
323fedb @ckeen Added browsing page
authored
134 (tabularize (map format-row (fetch-last-pastes from n))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
135 header: '("Nickname" "Title" "Date"))
136 (<p> "No pastes so far."))))
137
323fedb @ckeen Added browsing page
authored
138 (define (navigation-links)
139 (<div> id: "menu"
140 (<ul>
141 (apply ++ (map (lambda (m)
142 (<li> (link (make-pathname base-path (car m))
143 (cdr m))))
144 '(("" . "New Paste")
a322814 @ckeen Added about page
authored
145 ("browse" . "Browse pastes")
146 ("about" . "What is this?")))))))
323fedb @ckeen Added browsing page
authored
147
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
148 (define (recent-pastes n)
149 (<div> class: "paste-list"
150 (<h2> "The last " n " pastes so far: ")
151 (make-post-table n)))
152
153 (define (paste-form #!key annotate-id)
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
154 (let* ((hash/captcha (and use-captcha? (get-captcha captchas)))
155 (captcha-hash (and use-captcha? (car hash/captcha)))
156 (captcha (and use-captcha? (cdr hash/captcha))))
157 (<div> class: "paste-form"
158 (<h2> "Enter a new " (if annotate-id " annotation:" " paste:"))
159 (form
160 (++ (if use-captcha?
161 (hidden-input 'captcha-hash captcha-hash)
162 "")
163 (tabularize
164 (append
165 `(( "Your nick: " ,(text-input 'nick))
9d5df2d @ckeen Move captcha down in form, no link to main menu on bail-out, check for
authored
166 ( "The title of your paste:" ,(text-input 'title) )
167 ( ,(++ "Your paste " (<i> "(mandatory)" " :"))
168 ,(<textarea> id: "paste" name: "paste" cols: 60 rows: 24)))
169 (if use-captcha?
170 `(( "Type in the text below:" ,(text-input 'captcha-user-answer))
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
171 ("" ,(<pre> id: "captcha" (captcha-figlet captcha))))
172 '())
9d5df2d @ckeen Move captcha down in form, no link to main menu on bail-out, check for
authored
173 `(("" ,(if vandusen-host
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
174 (<input> name: "notify-irc"
175 type: "checkbox"
176 checked: "checked"
177 "Please notify the #chicken channel on freenode.")
178 ""))
179 ,(list (if annotate-id (hidden-input 'id annotate-id) "")
180 (submit-input value: "Submit paste!"))))))
181 action: (make-pathname base-path "paste")
182 method: "post"))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
183
184 (define (fetch-paste id)
db42cc9 @ckeen Fix fetch rows again *sigh*
authored
185 (and id
186 (let ((r ($db "select * from pastes where hash=? order by time desc" values: (list id))))
47a09cb @ckeen Revert refactor of fetch-pastes
authored
187 (and (not (null? r)) r))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
188
189 (define (update-paste id snippet)
190 (insert-paste id snippet))
191
192 (define (insert-paste id paste)
193 (let ((author (first paste))
194 (title (second paste))
195 (time (third paste))
196 (paste (fourth paste)))
197 ($db "insert into pastes (hash, author, title, time, paste) values (?,?,?,?,?)"
198 values: (list id author title time paste))))
199
200 (define (bail-out . reasons)
201 (++ (<h1> "Ooops, something went wrong") (<br>)
202 (<div> id: "failure-reason" (fold (lambda (i r)
203 (++ r (sprintf "~a" i)))
204 "" reasons))
7e81bd5 @ckeen Spelling corrected by Andy
authored
205 "I am sorry for this, you better go back."))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
206
af2b0f1 @ckeen Added prettify-time for nicer display of the date.
authored
207 (define (prettify-time t)
208 (let* ((delta (- (current-seconds) t))
209 (fits
210 (lambda (d l)
211 (let ((r (inexact->exact (floor (/ delta d)))))
212 (if (and (< 0 r) (>= l r)) r #f)))))
213 (cond ((fits (* 60 60 24) 3) =>
214 (lambda (d) (sprintf "~a days ago" d)))
215 ((fits (* 60 60) 24) =>
216 (lambda (hrs)
217 (sprintf "~a hours ago" hrs)))
218 ((fits 60 (* 60 5)) => (lambda (m) (sprintf "~a minutes ago" m)))
219 ((fits 1 120) => (lambda (_) (sprintf "just now!")))
220 (else (sprintf "on ~a" (seconds->string t))))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
221
222 (define (print-snippet s #!key annotation? (count 0))
223 (++ (<div> class: "paste-header"
99d14e4 @DerGuteMoritz fix anchor names for permalinks
DerGuteMoritz authored
224 (<h3> (<a> name: (sprintf "a~A" count) (third s)))
b073245 @ckeen grammar correction thanks to Mario
authored
225 (if annotation? " added " " pasted ") " by " (second s) " "
af2b0f1 @ckeen Added prettify-time for nicer display of the date.
authored
226 (prettify-time (fourth s)))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
227 (<div> class: "paste"
228 (<pre> (<tt> class: "highlight scheme-language" (html-colorize 'scheme (fifth s)))))
229 (<div> class: "paste-footer"
230 " [ "
231 (link (make-pathname base-path
b79ffbf @ckeen Fix anchors as they need to start with a letter.
authored
232 (string-append "paste?id=" (first s) "#a" (->string count)))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
233 "permalink")
234 " | "
235 (link (make-pathname base-path
236 (string-append "raw?id=" (first s) "&annotation=" (->string count)))
237 "raw")
238 " ] ")))
239
240 (define (format-all-snippets snippets)
241 (fold (let ((c (length snippets)))
242 (lambda (p s)
243 (set! c (sub1 c))
01e0f56 @ckeen Fix detection of annotation
authored
244 (++ (print-snippet p annotation?: (= c (- (length snippets) 1)) count: c) s)))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
245 ""
246 snippets))
247
248 (define-page "/" ;; the main page, prefixed by base-path
249 (lambda ()
323fedb @ckeen Added browsing page
authored
250 (++
07b021e @ckeen Better wording. Navigation menu also on paste page.
authored
251 (<div> id: "content" (<h1> id: "heading" align: "center"
252 "Welcome to the chicken scheme pasting service")
323fedb @ckeen Added browsing page
authored
253 (++ (or (and-let* ((id ($ 'id))
254 (annotate ($ 'annotate)))
255 (cond ((fetch-paste id)
256 => (lambda (p)
257 (++ (format-all-snippets p)
258 (<h2> "Your annotation:")
259 (paste-form annotate-id: id))))
260 (else (bail-out "Found no paste to annotate with this id."))))
261 (paste-form))))
262 (navigation-links)))
9ad5656 @mario-goulart Page titles and slight optimization by using `with-request-variables'
mario-goulart authored
263 title: "Pastiche: the Chicken Scheme pasting service")
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
264
265 (define-page "paste"
266 (lambda ()
3227fa7 @ckeen Guard against paste being empty
authored
267 (with-request-variables ((nick (nonempty as-string))
268 (title (nonempty as-string))
9ad5656 @mario-goulart Page titles and slight optimization by using `with-request-variables'
mario-goulart authored
269 paste
270 id)
271 (html-page
07b021e @ckeen Better wording. Navigation menu also on paste page.
authored
272 (++
273 (<div> id: "content"
274 (or (and-let* ((nick (or (and nick (htmlize nick)) "anonymous"))
275 (title (or (and title (htmlize title)) "no title"))
276 (time (current-seconds))
af2b0f1 @ckeen Added prettify-time for nicer display of the date.
authored
277 (paste (and (not (equal? "" paste)) paste))
07b021e @ckeen Better wording. Navigation menu also on paste page.
authored
278 (hashsum (string->sha1sum
279 (++ nick title (->string time) paste)))
280 (url '())
281 (snippet (map
282 (lambda (i)
283 (if (and (string? i) (string-null? i))
284 "anonymous"
285 i))
286 (list nick title time paste))))
287 (if (and use-captcha?
288 (not (equal? ($ 'captcha-user-answer)
289 (and-let* ((hash ($ 'captcha-hash))
290 (captcha (alist-ref hash captchas equal?)))
291 (captcha-string captcha)))))
292 (bail-out "Wrong captcha answer.")
293 (if (string-null? paste)
294 (bail-out "I am not storing empty pastes.")
295 (begin (cond ((fetch-paste id)
296 => (lambda (p)
99d14e4 @DerGuteMoritz fix anchor names for permalinks
DerGuteMoritz authored
297 (let ((count (+ 1 (length (cdr p)))))
07b021e @ckeen Better wording. Navigation menu also on paste page.
authored
298 (update-paste id snippet)
299 (set! url (make-pathname
300 base-path
2b90e28 @ckeen Missed another broken anchor, thanks mario
authored
301 (++ "paste?id=" id "#a" (->string count)))))))
07b021e @ckeen Better wording. Navigation menu also on paste page.
authored
302 (else (insert-paste hashsum snippet)
cd47be7 @ckeen Use correct base-path in link url
authored
303 (set! url (make-pathname base-path (++ "paste?id=" hashsum)))))
07b021e @ckeen Better wording. Navigation menu also on paste page.
authored
304 (when ($ 'notify-irc) (notify nick title url))
cd47be7 @ckeen Use correct base-path in link url
authored
305 (++ (<h2> align: "center" "Thanks for your paste!")
306 (<p> "Hi " nick ", thanks for pasting: " (<em> title) (<br>))
307 (<p> align: "center") "Your paste can be reached with this url: " (link url url))))))
07b021e @ckeen Better wording. Navigation menu also on paste page.
authored
308 (cond ((fetch-paste id)
309 => (lambda (p)
310 (++
311 (format-all-snippets p)
312 (<div> id: "paste-footer"
313 (<h2> align: "center"
314 (link (++ base-path "?id=" id
315 ";annotate=t") "Annotate this paste!"))))))
316 (else (bail-out "Could not find a paste with this id:" id)))))
317 (navigation-links))
9ad5656 @mario-goulart Page titles and slight optimization by using `with-request-variables'
mario-goulart authored
318 css: (page-css)
319 title: (conc "Pastes for " id))))
320 no-template: #t)
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
321
322 (define-page "raw"
323 (lambda ()
324 (awful-response-headers '((content-type "text/plain")))
325 (let* ((id ($ 'id))
326 (annotation ($ 'annotation as-number))
327 (paste (fetch-paste id)))
328 (or (and paste annotation (<= annotation (length paste)) (fifth (list-ref (reverse paste) annotation)))
329 paste
07b021e @ckeen Better wording. Navigation menu also on paste page.
authored
330 (bail-out "Could not find a paste with id " id))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
331 no-template: #t)
323fedb @ckeen Added browsing page
authored
332
333 (define (number-of-posts)
334 (let ((n ($db "select count(hash) from pastes")))
af2b0f1 @ckeen Added prettify-time for nicer display of the date.
authored
335 (and n (caar n))))
323fedb @ckeen Added browsing page
authored
336
337 (define-page "browse"
338 (lambda ()
339 (with-request-variables
340 ((from as-number)
341 (to as-number))
2112ff5 @ckeen Better guard against wrong input
authored
342 (let* ((nposts (number-of-posts))
343 (from (if (and from (>= from 0) (<= from nposts)) from 0))
344 (to (if (and to (> to from) (<= to nposts)) to browsing-steps))
323fedb @ckeen Added browsing page
authored
345 (older-to (min (+ to browsing-steps) nposts))
346 (older-from (+ from browsing-steps))
347 (newer-from (- from browsing-steps))
348 (newer-to (max (- to browsing-steps) browsing-steps))
349 (history-path (make-pathname base-path "browse")))
350 (html-page
351 (++ (<div> id: "content"
70cc616 @ckeen Move around navigation links for browsing
authored
352 (<h2> align: "center" "Browsing pastes")
323fedb @ckeen Added browsing page
authored
353 (<div> id: "browse-navigation"
354 align: "center"
355 (if (>= newer-from 0) (link (sprintf "~a?from=~a;to=~a" history-path newer-from newer-to)
356 "< newer")
357 "< newer")
358 " ... "
359 (if (and (not (= to nposts)) (<= older-to nposts))
360 (link (sprintf "~a?from=~a;to=~a" history-path older-from older-to)
361 "older >")
70cc616 @ckeen Move around navigation links for browsing
authored
362 "older >"))
363 (make-post-table to from))
a322814 @ckeen Added about page
authored
364 (navigation-links)))))))
365 (define-page "about"
366 (lambda ()
367 (html-page
368 (++ (<div> id: "content"
369 (<h2> "You have reached the CHICKEN scheme pasting service")
370 (<p> (htmlize "These pages are maintained by the CHICKEN scheme
371 project team. Anyone that enters a correct CAPTCHA response is allowed
7e81bd5 @ckeen Spelling corrected by Andy
authored
372 to post anything he likes. If you find objectionable content, feel
a322814 @ckeen Added about page
authored
373 free to drop a mail at chicken-janitors <at> nongnu dot org"))
374 (<p> "The source code for these pages is
375 distributed under a BSD license at C-Keen's "
376 (link "https://github.com/ckeen/pastiche" "github repo"))
377 (<p> "Our thanks go to chandler for the famous "
378 (link "http://paste.lisp.org" "lisppaste") " "
379 (link "http://www.cliki.net/lisppaste" "(cliki page)")
380 " bot and the same disclaimer applies:")
381 (<p> "Lisppaste pastes can be made by anyone at
382 any time. Imagine a fearsomely comprehensive disclaimer of
383 liability. Now fear, comprehensively."))
384 (navigation-links))))))))
385
323fedb @ckeen Added browsing page
authored
386
Something went wrong with that request. Please try again.