Skip to content

HTTPS clone URL

Subversion checkout URL

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