Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 393 lines (352 sloc) 17.623 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
afbc95d @ckeen Set the access method explicitly as needed for newer awful versions. Tha...
authored
266 (define handle-paste
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
267 (lambda ()
5d8b682 @ckeen Show the paste's title in <title> tags
authored
268 (let ((paste-title "Untitled paste"))
269 (with-request-variables ((nick (nonempty as-string))
270 (title (nonempty as-string))
271 paste
272 id)
273 (html-page
274 (++
275 (<div> id: "content"
276 (or (and-let* ((nick (or (and nick (htmlize nick)) "anonymous"))
277 (title (or (and title (htmlize title)) "no title"))
278 (time (current-seconds))
279 (paste (and (not (equal? "" paste)) paste))
280 (hashsum (string->sha1sum
281 (++ nick title (->string time) paste)))
282 (url '())
283 (snippet (map
284 (lambda (i)
285 (if (and (string? i) (string-null? i))
286 "anonymous"
287 i))
288 (list nick title time paste))))
289 (if (and use-captcha?
290 (not (equal? ($ 'captcha-user-answer)
291 (and-let* ((hash ($ 'captcha-hash))
292 (captcha (alist-ref hash captchas equal?)))
293 (captcha-string captcha)))))
294 (bail-out "Wrong captcha answer.")
295 (if (string-null? paste)
296 (bail-out "I am not storing empty pastes.")
297 (begin (cond ((fetch-paste id)
298 => (lambda (p)
299 (let ((count (+ 1 (length (cdr p)))))
300 (update-paste id snippet)
301 (set! url (make-pathname
302 base-path
303 (++ "paste?id=" id "#a" (->string count)))))))
304 (else (insert-paste hashsum snippet)
305 (set! url (make-pathname base-path (++ "paste?id=" hashsum)))))
306 (set! paste-title title)
307 (when ($ 'notify-irc) (notify nick title url))
308 (++ (<h2> align: "center" "Thanks for your paste!")
309 (<p> "Hi " nick ", thanks for pasting: " (<em> title) (<br>))
310 (<p> align: "center") "Your paste can be reached with this url: " (link url url))))))
311 (cond ((fetch-paste id)
312 => (lambda (p)
313 (set! paste-title (third (last p)))
314 (++
315 (format-all-snippets p)
316 (<div> id: "paste-footer"
317 (<h2> align: "center"
318 (link (++ base-path "?id=" id
319 ";annotate=t") "Annotate this paste!"))))))
320 (else (bail-out "Could not find a paste with this id:" id)))))
321 (navigation-links))
322 css: (page-css)
afbc95d @ckeen Set the access method explicitly as needed for newer awful versions. Tha...
authored
323 title: paste-title)))))
324
325 (define-page "paste" handle-paste method: 'POST no-template: #t)
326 (define-page "paste" handle-paste method: 'GET no-template: #t)
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
327
328 (define-page "raw"
329 (lambda ()
330 (awful-response-headers '((content-type "text/plain")))
331 (let* ((id ($ 'id))
332 (annotation ($ 'annotation as-number))
333 (paste (fetch-paste id)))
334 (or (and paste annotation (<= annotation (length paste)) (fifth (list-ref (reverse paste) annotation)))
335 paste
07b021e @ckeen Better wording. Navigation menu also on paste page.
authored
336 (bail-out "Could not find a paste with id " id))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
337 no-template: #t)
323fedb @ckeen Added browsing page
authored
338
339 (define (number-of-posts)
340 (let ((n ($db "select count(hash) from pastes")))
af2b0f1 @ckeen Added prettify-time for nicer display of the date.
authored
341 (and n (caar n))))
323fedb @ckeen Added browsing page
authored
342
343 (define-page "browse"
344 (lambda ()
345 (with-request-variables
346 ((from as-number)
347 (to as-number))
2112ff5 @ckeen Better guard against wrong input
authored
348 (let* ((nposts (number-of-posts))
349 (from (if (and from (>= from 0) (<= from nposts)) from 0))
350 (to (if (and to (> to from) (<= to nposts)) to browsing-steps))
323fedb @ckeen Added browsing page
authored
351 (older-to (min (+ to browsing-steps) nposts))
352 (older-from (+ from browsing-steps))
353 (newer-from (- from browsing-steps))
354 (newer-to (max (- to browsing-steps) browsing-steps))
355 (history-path (make-pathname base-path "browse")))
356 (html-page
357 (++ (<div> id: "content"
70cc616 @ckeen Move around navigation links for browsing
authored
358 (<h2> align: "center" "Browsing pastes")
323fedb @ckeen Added browsing page
authored
359 (<div> id: "browse-navigation"
360 align: "center"
361 (if (>= newer-from 0) (link (sprintf "~a?from=~a;to=~a" history-path newer-from newer-to)
362 "< newer")
363 "< newer")
364 " ... "
365 (if (and (not (= to nposts)) (<= older-to nposts))
366 (link (sprintf "~a?from=~a;to=~a" history-path older-from older-to)
367 "older >")
70cc616 @ckeen Move around navigation links for browsing
authored
368 "older >"))
369 (make-post-table to from))
a322814 @ckeen Added about page
authored
370 (navigation-links)))))))
371 (define-page "about"
372 (lambda ()
373 (html-page
374 (++ (<div> id: "content"
375 (<h2> "You have reached the CHICKEN scheme pasting service")
376 (<p> (htmlize "These pages are maintained by the CHICKEN scheme
377 project team. Anyone that enters a correct CAPTCHA response is allowed
7e81bd5 @ckeen Spelling corrected by Andy
authored
378 to post anything he likes. If you find objectionable content, feel
a322814 @ckeen Added about page
authored
379 free to drop a mail at chicken-janitors <at> nongnu dot org"))
380 (<p> "The source code for these pages is
381 distributed under a BSD license at C-Keen's "
382 (link "https://github.com/ckeen/pastiche" "github repo"))
383 (<p> "Our thanks go to chandler for the famous "
384 (link "http://paste.lisp.org" "lisppaste") " "
385 (link "http://www.cliki.net/lisppaste" "(cliki page)")
386 " bot and the same disclaimer applies:")
387 (<p> "Lisppaste pastes can be made by anyone at
388 any time. Imagine a fearsomely comprehensive disclaimer of
389 liability. Now fear, comprehensively."))
390 (navigation-links))))))))
391
323fedb @ckeen Added browsing page
authored
392
Something went wrong with that request. Please try again.