Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 347 lines (308 sloc) 12.531 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
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
893921f0 »
2011-05-18 Initial captcha support (using figlet)
19 utils
20 extras
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
21 (srfi 1 13))
22
23
893921f0 »
2011-05-18 Initial captcha support (using figlet)
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 ;;;
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
67 (define (pastiche base-path db-file
68 #!key (vandusen-port 22722)
ba56d21d »
2011-05-13 Add vandusen-host and base-url as parameter
69 (vandusen-host "localhost")
70 (base-url "http://paste.call-cc.org")
893921f0 »
2011-05-18 Initial captcha support (using figlet)
71 (use-captcha? #t)
72 (num-captchas 500)
323fedb4 »
2011-05-22 Added browsing page
73 (browsing-steps 15)
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
74 (awful-settings (lambda (_) (_))))
75
76 (parameterize ((app-root-path base-path))
77
323fedb4 »
2011-05-22 Added browsing page
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)))))
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
87
893921f0 »
2011-05-18 Initial captcha support (using figlet)
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
9d5df2dc »
2011-05-18 Move captcha down in form, no link to main menu on bail-out, check for
98 (define captchas (and use-captcha? (create-captchas num-captchas)))
893921f0 »
2011-05-18 Initial captcha support (using figlet)
99
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
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)
ba56d21d »
2011-05-13 Add vandusen-host and base-url as parameter
107 (when vandusen-host
108 (ignore-errors
b1518984 »
2011-05-14 Avoid double slash with make-pathname
109 (let ((stuff (sprintf "#chicken ~s pasted ~s ~a"
110 nick title (make-pathname base-url url))))
ba56d21d »
2011-05-13 Add vandusen-host and base-url as parameter
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))))))
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
116
323fedb4 »
2011-05-22 Added browsing page
117 (define (fetch-last-pastes from to)
118 (let ((r ($db "select * from pastes order by time desc limit ?,?" values: (list from to))))
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
119 r))
120
323fedb4 »
2011-05-22 Added browsing page
121 (define (make-post-table n #!optional (from 0))
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
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
126 (seconds->string (fourth r)))) ;date
127
128 (<div> class: "paste-table"
129 (or
323fedb4 »
2011-05-22 Added browsing page
130 (tabularize (map format-row (fetch-last-pastes from n))
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
131 header: '("Nickname" "Title" "Date"))
132 (<p> "No pastes so far."))))
133
323fedb4 »
2011-05-22 Added browsing page
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")
141 ("browse" . "Browse pastes")))))))
142
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
143 (define (recent-pastes n)
144 (<div> class: "paste-list"
145 (<h2> "The last " n " pastes so far: ")
146 (make-post-table n)))
147
148 (define (paste-form #!key annotate-id)
893921f0 »
2011-05-18 Initial captcha support (using figlet)
149 (let* ((hash/captcha (and use-captcha? (get-captcha captchas)))
150 (captcha-hash (and use-captcha? (car hash/captcha)))
151 (captcha (and use-captcha? (cdr hash/captcha))))
152 (<div> class: "paste-form"
153 (<h2> "Enter a new " (if annotate-id " annotation:" " paste:"))
154 (form
155 (++ (if use-captcha?
156 (hidden-input 'captcha-hash captcha-hash)
157 "")
158 (tabularize
159 (append
160 `(( "Your nick: " ,(text-input 'nick))
9d5df2dc »
2011-05-18 Move captcha down in form, no link to main menu on bail-out, check for
161 ( "The title of your paste:" ,(text-input 'title) )
162 ( ,(++ "Your paste " (<i> "(mandatory)" " :"))
163 ,(<textarea> id: "paste" name: "paste" cols: 60 rows: 24)))
164 (if use-captcha?
165 `(( "Type in the text below:" ,(text-input 'captcha-user-answer))
893921f0 »
2011-05-18 Initial captcha support (using figlet)
166 ("" ,(<pre> id: "captcha" (captcha-figlet captcha))))
167 '())
9d5df2dc »
2011-05-18 Move captcha down in form, no link to main menu on bail-out, check for
168 `(("" ,(if vandusen-host
893921f0 »
2011-05-18 Initial captcha support (using figlet)
169 (<input> name: "notify-irc"
170 type: "checkbox"
171 checked: "checked"
172 "Please notify the #chicken channel on freenode.")
173 ""))
174 ,(list (if annotate-id (hidden-input 'id annotate-id) "")
175 (submit-input value: "Submit paste!"))))))
176 action: (make-pathname base-path "paste")
177 method: "post"))))
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
178
179 (define (fetch-paste id)
47a09cb7 »
2011-05-22 Revert refactor of fetch-pastes
180 (let ((r ($db "select * from pastes where hash=? order by time desc" values: (list id))))
181 (and id
182 (and (not (null? r)) r))))
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
183
184 (define (update-paste id snippet)
185 (insert-paste id snippet))
186
187 (define (insert-paste id paste)
188 (let ((author (first paste))
189 (title (second paste))
190 (time (third paste))
191 (paste (fourth paste)))
192 ($db "insert into pastes (hash, author, title, time, paste) values (?,?,?,?,?)"
193 values: (list id author title time paste))))
194
195 (define (bail-out . reasons)
196 (++ (<h1> "Ooops, something went wrong") (<br>)
197 (<div> id: "failure-reason" (fold (lambda (i r)
198 (++ r (sprintf "~a" i)))
199 "" reasons))
9d5df2dc »
2011-05-18 Move captcha down in form, no link to main menu on bail-out, check for
200 "I am sorry for his, you better go back."))
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
201
202
203 (define (print-snippet s #!key annotation? (count 0))
204 (++ (<div> class: "paste-header"
07b021e7 »
2011-05-22 Better wording. Navigation menu also on paste page.
205 (<h3> (<a> name: (if annotation? (->string count) "") (third s)))
206 (if annotation? " added " " pasted ") " by " (second s)
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
207 " on " (seconds->string (fourth s)))
208 (<div> class: "paste"
209 (<pre> (<tt> class: "highlight scheme-language" (html-colorize 'scheme (fifth s)))))
210 (<div> class: "paste-footer"
211 " [ "
212 (link (make-pathname base-path
213 (string-append "paste?id=" (first s) "#" (->string count)))
214 "permalink")
215 " | "
216 (link (make-pathname base-path
217 (string-append "raw?id=" (first s) "&annotation=" (->string count)))
218 "raw")
219 " ] ")))
220
221 (define (format-all-snippets snippets)
222 (fold (let ((c (length snippets)))
223 (lambda (p s)
224 (set! c (sub1 c))
225 (++ (print-snippet p annotation?: (not (= c (- (length (car snippets)) 1))) count: c) s)))
226 ""
227 snippets))
228
229 (define-page "/" ;; the main page, prefixed by base-path
230 (lambda ()
323fedb4 »
2011-05-22 Added browsing page
231 (++
07b021e7 »
2011-05-22 Better wording. Navigation menu also on paste page.
232 (<div> id: "content" (<h1> id: "heading" align: "center"
233 "Welcome to the chicken scheme pasting service")
323fedb4 »
2011-05-22 Added browsing page
234 (++ (or (and-let* ((id ($ 'id))
235 (annotate ($ 'annotate)))
236 (cond ((fetch-paste id)
237 => (lambda (p)
238 (++ (format-all-snippets p)
239 (<h2> "Your annotation:")
240 (paste-form annotate-id: id))))
241 (else (bail-out "Found no paste to annotate with this id."))))
242 (paste-form))))
243 (navigation-links)))
9ad5656d »
2011-05-17 Page titles and slight optimization by using `with-request-variables'
244 title: "Pastiche: the Chicken Scheme pasting service")
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
245
246 (define-page "paste"
247 (lambda ()
3227fa71 »
2011-05-18 Guard against paste being empty
248 (with-request-variables ((nick (nonempty as-string))
249 (title (nonempty as-string))
9ad5656d »
2011-05-17 Page titles and slight optimization by using `with-request-variables'
250 paste
251 id)
252 (html-page
07b021e7 »
2011-05-22 Better wording. Navigation menu also on paste page.
253 (++
254 (<div> id: "content"
255 (or (and-let* ((nick (or (and nick (htmlize nick)) "anonymous"))
256 (title (or (and title (htmlize title)) "no title"))
257 (time (current-seconds))
258 (paste paste)
259 (hashsum (string->sha1sum
260 (++ nick title (->string time) paste)))
261 (url '())
262 (snippet (map
263 (lambda (i)
264 (if (and (string? i) (string-null? i))
265 "anonymous"
266 i))
267 (list nick title time paste))))
268 (if (and use-captcha?
269 (not (equal? ($ 'captcha-user-answer)
270 (and-let* ((hash ($ 'captcha-hash))
271 (captcha (alist-ref hash captchas equal?)))
272 (captcha-string captcha)))))
273 (bail-out "Wrong captcha answer.")
274 (if (string-null? paste)
275 (bail-out "I am not storing empty pastes.")
276 (begin (cond ((fetch-paste id)
277 => (lambda (p)
278 (let ((count (length (cdr p))))
279 (update-paste id snippet)
280 (set! url (make-pathname
281 base-path
282 (++ "paste?id=" id "#" (->string count)))))))
283 (else (insert-paste hashsum snippet)
284 (set! url (++ "paste?id=" hashsum))))
285 (when ($ 'notify-irc) (notify nick title url))
286 (++ (<h1> "Thanks for your paste!")
287 "Hi " nick (<br>) "Thanks for pasting: " (<em> title) (<br>)
288 "Your paste can be reached with this url: " (link url url))))))
289 (cond ((fetch-paste id)
290 => (lambda (p)
291 (++
292 (format-all-snippets p)
293 (<div> id: "paste-footer"
294 (<h2> align: "center"
295 (link (++ base-path "?id=" id
296 ";annotate=t") "Annotate this paste!"))))))
297 (else (bail-out "Could not find a paste with this id:" id)))))
298 (navigation-links))
9ad5656d »
2011-05-17 Page titles and slight optimization by using `with-request-variables'
299 css: (page-css)
300 title: (conc "Pastes for " id))))
301 no-template: #t)
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
302
303 (define-page "raw"
304 (lambda ()
305 (awful-response-headers '((content-type "text/plain")))
306 (let* ((id ($ 'id))
307 (annotation ($ 'annotation as-number))
308 (paste (fetch-paste id)))
309 (or (and paste annotation (<= annotation (length paste)) (fifth (list-ref (reverse paste) annotation)))
310 paste
07b021e7 »
2011-05-22 Better wording. Navigation menu also on paste page.
311 (bail-out "Could not find a paste with id " id))))
ea33c53a »
2011-04-14 initial commit, thanks to Mario Goulart
312 no-template: #t)
323fedb4 »
2011-05-22 Added browsing page
313
314 (define (number-of-posts)
315 (let ((n ($db "select count(hash) from pastes")))
316 (and n (caar n))))
317
318 (define-page "browse"
319 (lambda ()
320 (with-request-variables
321 ((from as-number)
322 (to as-number))
323 (let* ((from (or from 0))
324 (to (or to browsing-steps))
325 (nposts (number-of-posts))
326 (older-to (min (+ to browsing-steps) nposts))
327 (older-from (+ from browsing-steps))
328 (newer-from (- from browsing-steps))
329 (newer-to (max (- to browsing-steps) browsing-steps))
330 (history-path (make-pathname base-path "browse")))
331 (html-page
332 (++ (<div> id: "content"
333 (<h2> align: "center" "Browsing pastes from " from " to " to " of " nposts)
334 (make-post-table to from)
335 (<div> id: "browse-navigation"
336 align: "center"
337 (if (>= newer-from 0) (link (sprintf "~a?from=~a;to=~a" history-path newer-from newer-to)
338 "< newer")
339 "< newer")
340 " ... "
341 (if (and (not (= to nposts)) (<= older-to nposts))
342 (link (sprintf "~a?from=~a;to=~a" history-path older-from older-to)
343 "older >")
344 "older >")))
345 (navigation-links))))))))))
346
Something went wrong with that request. Please try again.