Skip to content

HTTPS clone URL

Subversion checkout URL

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