Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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