Skip to content
Newer
Older
100644 219 lines (194 sloc) 9.3 KB
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored Apr 14, 2011
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
19 (srfi 1 13))
20
21
22 (define (pastiche base-path db-file
23 #!key (vandusen-port 22722)
ba56d21 @ckeen Add vandusen-host and base-url as parameter
authored May 13, 2011
24 (vandusen-host "localhost")
25 (base-url "http://paste.call-cc.org")
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored Apr 14, 2011
26 (awful-settings (lambda (_) (_))))
27
28 (parameterize ((app-root-path base-path))
29
30 (add-request-handler-hook!
31 'awful-paste
32 (lambda (path handler)
33 (when (string-prefix? base-path path)
34 (switch-to-sql-de-lite-database)
35 (parameterize ((app-root-path base-path)
36 (db-credentials db-file)
37 (page-css "http://wiki.call-cc.org/chicken.css"))
38 (awful-settings handler)))))
39
40 ;; The database needs to be initialised once
41 (unless (file-exists? db-file)
42 (let ((db (open-database db-file)))
43 (exec (sql db "create table pastes(hash text, author text, title text, time float, paste text)"))
44 (close-database db)))
45
46
47 (define (notify nick title url)
ba56d21 @ckeen Add vandusen-host and base-url as parameter
authored May 13, 2011
48 (when vandusen-host
49 (ignore-errors
b151898 @ckeen Avoid double slash with make-pathname
authored May 14, 2011
50 (let ((stuff (sprintf "#chicken ~s pasted ~s ~a"
51 nick title (make-pathname base-url url))))
ba56d21 @ckeen Add vandusen-host and base-url as parameter
authored May 13, 2011
52 (let-values (((i o) (tcp-connect vandusen-host vandusen-port)))
53 (display stuff o)
54 (newline o)
55 (close-input-port i)
56 (close-output-port o))))))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored Apr 14, 2011
57
58 (define (fetch-last-pastes n)
59 (let ((r ($db "select * from pastes order by time desc limit ?" values: (list n))))
60 r))
61
62 (define (make-post-table n)
63 (define (format-row r)
64 (list (second r) ; Nickname
65 (link (make-pathname base-path (string-append "/paste?id=" (first r)))
66 (third r)) ; title
67 (seconds->string (fourth r)))) ;date
68
69 (<div> class: "paste-table"
70 (or
71 (tabularize (map format-row (fetch-last-pastes n))
72 header: '("Nickname" "Title" "Date"))
73 (<p> "No pastes so far."))))
74
75 (define (recent-pastes n)
76 (<div> class: "paste-list"
77 (<h2> "The last " n " pastes so far: ")
78 (make-post-table n)))
79
80 (define (paste-form #!key annotate-id)
81 (<div> class: "paste-form"
82 (<h2> "Enter a new " (if annotate-id " annotation:" " paste:"))
83 (form (tabularize
84 `(( "Your nick: " ,(text-input 'nick))
85 ( "The title of your paste:" ,(text-input 'title) )
86 ( ,(++ "Your paste " (<i> "(mandatory)" " :"))
87 ,(<textarea> id: "paste" name: "paste" cols: 60 rows: 24))
ba56d21 @ckeen Add vandusen-host and base-url as parameter
authored May 13, 2011
88 ("" ,(if vandusen-host
89 (<input> name: "notify-irc"
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored Apr 14, 2011
90 type: "checkbox"
91 checked: "checked"
ba56d21 @ckeen Add vandusen-host and base-url as parameter
authored May 13, 2011
92 "Please notify the #chicken channel on freenode.")
93 ""))
ea33c53 @ckeen initial commit, thanks to Mario Goulart
authored Apr 14, 2011
94 ,(list (if annotate-id (hidden-input 'id annotate-id) "")
95 (submit-input value: "Submit paste!"))))
96 action: (make-pathname base-path "paste")
97 method: "post")))
98
99 (define (fetch-paste id)
100 (and id
101 (let ((r ($db "select * from pastes where hash=? order by time desc" values: (list id))))
102 (or (null? r) r))))
103
104 (define (update-paste id snippet)
105 (insert-paste id snippet))
106
107 (define (insert-paste id paste)
108 (let ((author (first paste))
109 (title (second paste))
110 (time (third paste))
111 (paste (fourth paste)))
112 ($db "insert into pastes (hash, author, title, time, paste) values (?,?,?,?,?)"
113 values: (list id author title time paste))))
114
115 (define (bail-out . reasons)
116 (++ (<h1> "Ooops, something went wrong") (<br>)
117 (<div> id: "failure-reason" (fold (lambda (i r)
118 (++ r (sprintf "~a" i)))
119 "" reasons))
120 "I am sorry for his, you "
121 (link base-path "better go back.")))
122
123
124 (define (print-snippet s #!key annotation? (count 0))
125 (++ (<div> class: "paste-header"
126 (second s) (if annotation? " added " " pasted ")
127 (<a> name: (if annotation? (->string count) "") (third s))
128 " on " (seconds->string (fourth s)))
129 (<div> class: "paste"
130 (<pre> (<tt> class: "highlight scheme-language" (html-colorize 'scheme (fifth s)))))
131 (<div> class: "paste-footer"
132 " [ "
133 (link (make-pathname base-path
134 (string-append "paste?id=" (first s) "#" (->string count)))
135 "permalink")
136 " | "
137 (link (make-pathname base-path
138 (string-append "raw?id=" (first s) "&annotation=" (->string count)))
139 "raw")
140 " ] ")))
141
142 (define (format-all-snippets snippets)
143 (fold (let ((c (length snippets)))
144 (lambda (p s)
145 (set! c (sub1 c))
146 (++ (print-snippet p annotation?: (not (= c (- (length (car snippets)) 1))) count: c) s)))
147 ""
148 snippets))
149
150 (define-page "/" ;; the main page, prefixed by base-path
151 (lambda ()
152 (<div> id: "content" (<h1> id: "heading" "Welcome to the chicken scheme pasting service")
153 (<p> id: "subheading" (<small> "Home of lost parentheses"))
154 (++ (or (and-let* ((id ($ 'id))
155 (annotate ($ 'annotate)))
156 (cond ((fetch-paste id)
157 => (lambda (p)
158 (++ (format-all-snippets p)
159 (<h2> "Your annotation:")
160 (paste-form annotate-id: id))))
161 (else (bail-out "Found no paste to annotate with this id."))))
162 (++ (recent-pastes 10)
163 (paste-form)))))))
164
165 (define-page "paste"
166 (lambda ()
167 (<div> id: "content"
168 (or (and-let* ((nick (and ($ 'nick) (htmlize ($ 'nick))))
169 (title (and ($ 'title) (htmlize ($ 'title))))
170 (paste ($ 'paste))
171 (time (current-seconds))
172 (hashsum (string->sha1sum
173 (++ nick title (->string time) paste)))
174 (url '())
175 (snippet (map
176 (lambda (i)
177 (if (and (string? i) (string-null? i))
178 "anonymous"
179 i))
180 (list nick title time paste))))
181 (if (string-null? paste)
182 (bail-out "I am not storing empty pastes.")
183 (begin (cond ((fetch-paste ($ 'id))
184 => (lambda (p)
185 (let ((count (length (cdr p))))
186 (update-paste ($ 'id) snippet)
187 (set! url (make-pathname
188 base-path
189 (++ "paste?id=" ($ 'id) "#" (->string count)))))))
190 (else (insert-paste hashsum snippet)
191 (set! url (++ "paste?id=" hashsum))))
192 (when ($ 'notify-irc) (notify nick title url))
193 (++ (<h1> "Thanks for your paste!")
194 "Hi " nick (<br>) "Thanks for pasting: " (<em> title) (<br>)
195 "Your paste can be reached with this url: " (link url url)))))
196 (cond ((fetch-paste ($ 'id))
197 => (lambda (p)
198 (++
199 (<h2> "Showing pastes for " ($ 'id))
200 (format-all-snippets p)
201 (<div> id: "paste-footer"
202 (<h2> (link (++ base-path "?id=" ($ 'id)
203 ";annotate=t") "Add an annotation to this paste!"))))))
204 (else (bail-out "Could not find a paste with this id:" ($ 'id)))))
205 (<p> (link base-path "Main page")))))
206
207 (define-page "raw"
208 (lambda ()
209 (awful-response-headers '((content-type "text/plain")))
210 (let* ((id ($ 'id))
211 (annotation ($ 'annotation as-number))
212 (paste (fetch-paste id)))
213 (or (and paste annotation (<= annotation (length paste)) (fifth (list-ref (reverse paste) annotation)))
214 paste
215 (++ (bail-out "Could not find a paste with id " id)
216 (<p> (link base-path "Main page"))))))
217 no-template: #t)
218 )))
Something went wrong with that request. Please try again.