Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 303 lines (267 sloc) 12.836 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)
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
73 (awful-settings (lambda (_) (_))))
74
75 (parameterize ((app-root-path base-path))
76
77 (add-request-handler-hook!
78 'awful-paste
79 (lambda (path handler)
80 (when (string-prefix? base-path path)
81 (switch-to-sql-de-lite-database)
82 (parameterize ((app-root-path base-path)
83 (db-credentials db-file)
84 (page-css "http://wiki.call-cc.org/chicken.css"))
85 (awful-settings handler)))))
86
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
87 (define figlet-installed?
88 (handle-exceptions exn
89 #f
90 (system* "figlet -v 2>&1 > /dev/null")))
91
92 (when (and use-captcha? (not figlet-installed?))
93 (print "WARNING: `use-captcha?' indicates that captchas are enabled but figlet "
94 "doesn't seem to be installed. Disabling captchas.")
95 (set! use-captcha? #f))
96
9d5df2d @ckeen Move captcha down in form, no link to main menu on bail-out, check for
authored
97 (define captchas (and use-captcha? (create-captchas num-captchas)))
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
98
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
99 ;; The database needs to be initialised once
100 (unless (file-exists? db-file)
101 (let ((db (open-database db-file)))
102 (exec (sql db "create table pastes(hash text, author text, title text, time float, paste text)"))
103 (close-database db)))
104
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
117 (define (fetch-last-pastes n)
118 (let ((r ($db "select * from pastes order by time desc limit ?" values: (list n))))
119 r))
120
121 (define (make-post-table n)
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
130 (tabularize (map format-row (fetch-last-pastes n))
131 header: '("Nickname" "Title" "Date"))
132 (<p> "No pastes so far."))))
133
134 (define (recent-pastes n)
135 (<div> class: "paste-list"
136 (<h2> "The last " n " pastes so far: ")
137 (make-post-table n)))
138
139 (define (paste-form #!key annotate-id)
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
140 (let* ((hash/captcha (and use-captcha? (get-captcha captchas)))
141 (captcha-hash (and use-captcha? (car hash/captcha)))
142 (captcha (and use-captcha? (cdr hash/captcha))))
143 (<div> class: "paste-form"
144 (<h2> "Enter a new " (if annotate-id " annotation:" " paste:"))
145 (form
146 (++ (if use-captcha?
147 (hidden-input 'captcha-hash captcha-hash)
148 "")
149 (tabularize
150 (append
151 `(( "Your nick: " ,(text-input 'nick))
9d5df2d @ckeen Move captcha down in form, no link to main menu on bail-out, check for
authored
152 ( "The title of your paste:" ,(text-input 'title) )
153 ( ,(++ "Your paste " (<i> "(mandatory)" " :"))
154 ,(<textarea> id: "paste" name: "paste" cols: 60 rows: 24)))
155 (if use-captcha?
156 `(( "Type in the text below:" ,(text-input 'captcha-user-answer))
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
157 ("" ,(<pre> id: "captcha" (captcha-figlet captcha))))
158 '())
9d5df2d @ckeen Move captcha down in form, no link to main menu on bail-out, check for
authored
159 `(("" ,(if vandusen-host
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
160 (<input> name: "notify-irc"
161 type: "checkbox"
162 checked: "checked"
163 "Please notify the #chicken channel on freenode.")
164 ""))
165 ,(list (if annotate-id (hidden-input 'id annotate-id) "")
166 (submit-input value: "Submit paste!"))))))
167 action: (make-pathname base-path "paste")
168 method: "post"))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
169
170 (define (fetch-paste id)
171 (and id
172 (let ((r ($db "select * from pastes where hash=? order by time desc" values: (list id))))
173 (or (null? r) r))))
174
175 (define (update-paste id snippet)
176 (insert-paste id snippet))
177
178 (define (insert-paste id paste)
179 (let ((author (first paste))
180 (title (second paste))
181 (time (third paste))
182 (paste (fourth paste)))
183 ($db "insert into pastes (hash, author, title, time, paste) values (?,?,?,?,?)"
184 values: (list id author title time paste))))
185
186 (define (bail-out . reasons)
187 (++ (<h1> "Ooops, something went wrong") (<br>)
188 (<div> id: "failure-reason" (fold (lambda (i r)
189 (++ r (sprintf "~a" i)))
190 "" reasons))
9d5df2d @ckeen Move captcha down in form, no link to main menu on bail-out, check for
authored
191 "I am sorry for his, you better go back."))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
192
193
194 (define (print-snippet s #!key annotation? (count 0))
195 (++ (<div> class: "paste-header"
196 (second s) (if annotation? " added " " pasted ")
197 (<a> name: (if annotation? (->string count) "") (third s))
198 " on " (seconds->string (fourth s)))
199 (<div> class: "paste"
200 (<pre> (<tt> class: "highlight scheme-language" (html-colorize 'scheme (fifth s)))))
201 (<div> class: "paste-footer"
202 " [ "
203 (link (make-pathname base-path
204 (string-append "paste?id=" (first s) "#" (->string count)))
205 "permalink")
206 " | "
207 (link (make-pathname base-path
208 (string-append "raw?id=" (first s) "&annotation=" (->string count)))
209 "raw")
210 " ] ")))
211
212 (define (format-all-snippets snippets)
213 (fold (let ((c (length snippets)))
214 (lambda (p s)
215 (set! c (sub1 c))
216 (++ (print-snippet p annotation?: (not (= c (- (length (car snippets)) 1))) count: c) s)))
217 ""
218 snippets))
219
220 (define-page "/" ;; the main page, prefixed by base-path
221 (lambda ()
222 (<div> id: "content" (<h1> id: "heading" "Welcome to the chicken scheme pasting service")
223 (<p> id: "subheading" (<small> "Home of lost parentheses"))
224 (++ (or (and-let* ((id ($ 'id))
225 (annotate ($ 'annotate)))
226 (cond ((fetch-paste id)
227 => (lambda (p)
c515aaf @mario-goulart Removing extra whitespaces.
mario-goulart authored
228 (++ (format-all-snippets p)
229 (<h2> "Your annotation:")
230 (paste-form annotate-id: id))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
231 (else (bail-out "Found no paste to annotate with this id."))))
232 (++ (recent-pastes 10)
9ad5656 @mario-goulart Page titles and slight optimization by using `with-request-variables'
mario-goulart authored
233 (paste-form))))))
234 title: "Pastiche: the Chicken Scheme pasting service")
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
235
236 (define-page "paste"
237 (lambda ()
9ad5656 @mario-goulart Page titles and slight optimization by using `with-request-variables'
mario-goulart authored
238 (with-request-variables ((nick (nonempty as-string))
239 (title (nonempty as-string))
240 paste
241 id)
242 (html-page
243 (<div> id: "content"
244 (or (and-let* ((nick (and nick (htmlize nick)))
245 (title (and title (htmlize title)))
246 (time (current-seconds))
247 (hashsum (string->sha1sum
248 (++ nick title (->string time) paste)))
249 (url '())
250 (snippet (map
251 (lambda (i)
252 (if (and (string? i) (string-null? i))
253 "anonymous"
254 i))
255 (list nick title time paste))))
893921f @mario-goulart Initial captcha support (using figlet)
mario-goulart authored
256 (if (and use-captcha?
257 (not (equal? ($ 'captcha-user-answer)
258 (and-let* ((hash ($ 'captcha-hash))
259 (captcha (alist-ref hash captchas equal?)))
260 (captcha-string captcha)))))
261 (bail-out "Wrong captcha answer.")
262 (if (string-null? paste)
263 (bail-out "I am not storing empty pastes.")
264 (begin (cond ((fetch-paste id)
265 => (lambda (p)
266 (let ((count (length (cdr p))))
267 (update-paste id snippet)
268 (set! url (make-pathname
269 base-path
270 (++ "paste?id=" id "#" (->string count)))))))
271 (else (insert-paste hashsum snippet)
272 (set! url (++ "paste?id=" hashsum))))
273 (when ($ 'notify-irc) (notify nick title url))
274 (++ (<h1> "Thanks for your paste!")
275 "Hi " nick (<br>) "Thanks for pasting: " (<em> title) (<br>)
276 "Your paste can be reached with this url: " (link url url))))))
9ad5656 @mario-goulart Page titles and slight optimization by using `with-request-variables'
mario-goulart authored
277 (cond ((fetch-paste id)
278 => (lambda (p)
279 (++
280 (<h2> "Showing pastes for " id)
281 (format-all-snippets p)
282 (<div> id: "paste-footer"
283 (<h2> (link (++ base-path "?id=" id
284 ";annotate=t") "Add an annotation to this paste!"))))))
285 (else (bail-out "Could not find a paste with this id:" id))))
286 (<p> (link base-path "Main page")))
287 css: (page-css)
288 title: (conc "Pastes for " id))))
289 no-template: #t)
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored
290
291 (define-page "raw"
292 (lambda ()
293 (awful-response-headers '((content-type "text/plain")))
294 (let* ((id ($ 'id))
295 (annotation ($ 'annotation as-number))
296 (paste (fetch-paste id)))
297 (or (and paste annotation (<= annotation (length paste)) (fifth (list-ref (reverse paste) annotation)))
298 paste
299 (++ (bail-out "Could not find a paste with id " id)
300 (<p> (link base-path "Main page"))))))
301 no-template: #t)
302 )))
Something went wrong with that request. Please try again.