blob: f15b6cbac025f33090aa8bb391d595905b010169 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
(in-package #:mulkcms)
(defparameter *database-connection-spec*
(list *database-name* *database-user* *database-password* *database-host*
:pooled-p t :use-ssl :try))
(unless (member "html-human-date" *template-formatters* :key #'car :test #'equal)
(setq *template-formatters*
(list* (cons "html-human-date" 'format-human-date)
(cons "html-short-human-date" 'format-short-human-date)
(cons "html-iso-date" 'format-iso-date)
(cons "article-html" 'format-article)
*template-formatters*)))
(defun call-with-db (thunk)
(call-with-connection *database-connection-spec* thunk))
(defmacro with-db (&body body)
`(call-with-db (lambda () ,@body)))
(defun find-template (template-name)
(first (directory (make-pathname :name template-name
:type :wild
:directory *templates*))))
(defun format-short-human-date (date)
;; FIXME
"(some date)")
(defun format-human-date (date)
;; FIXME
"(some date)")
(defun format-iso-date (date)
;; FIXME
"(some date)")
(defun template (template-name)
(parse-template-string (read-file-into-string (find-template template-name))))
(defun format-article (article-params)
(let ((article-template (template "article")))
(expand-template article-template article-params)))
(defun paramify-article (revision-data &optional (comments nil commentary-p))
(destructuring-bind (rid article date title content author format status
global-id &rest args)
revision-data
(declare (ignore args rid))
(list :publishing-date date
:title title
:body content
;;FIXME
:link ""
:commentary (if commentary-p (list :comments comments) nil)
:edit-link ""
:edit-button-label "Edit"
:comment-feed ""
:comment-feed-label "Comment feed"
:comments-label "Comments"
:comments-link ""
:comments-heading "Comments")))
(defun format-comment-content (text)
;; Taken from Mulkblog.
(with-html-output-to-string (out)
(loop for last-position = 0 then (cadr matches)
for matches = (ppcre:all-matches "(\\n|\\r|\\r\\n)(\\n|\\r|\\r\\n)+" text)
then (cddr matches)
while (not (endp matches))
do (htm (:p (esc (subseq text last-position (car matches)))))
finally
(htm (:p (esc (subseq text last-position)))))))
(defun find-article-revisions (article characteristics &optional fixed-characteristics)
;; CHARACTERISTICS --- a proper list.
;;
;; CHARACTERISTICS is a list of lists of (key . value) pairs. Each component list
;; is a precedence list of characteristics that are to be considered fallbacks for
;; each other and that will be tried in order.
(let* ((fixed-characteristics-conditions
(mapcar (lambda (x)
(format nil "AND EXISTS
(SELECT 1
FROM article_revision_characteristics
WHERE revision = article_revisions.id
AND characteristic = ~A
AND value = ~A)"
(sql-escape (car x))
(sql-escape (cdr x))))
fixed-characteristics))
(query (format nil
"SELECT *
FROM article_revisions
WHERE article = $1~
~{~&~A~}
ORDER BY date DESC"
fixed-characteristics-conditions)))
(when-let ((revisions (query query article :lists)))
(if (consp characteristics)
(dolist (potential-fixed-characteristic (first characteristics))
(when-let ((more-specific-revisions
(find-article-revisions article
(rest characteristics)
(cons potential-fixed-characteristic
fixed-characteristics))))
(return-from find-article-revisions more-specific-revisions)))
revisions))))
(defun paramify-comment (comment-revision-data)
(destructuring-bind (crid comment date content author format status
article-revision &rest args)
comment-revision-data
(declare (ignore args crid article-revision status format comment))
(list :publishing-date date
:body (format-comment-content content)
:author author
;;FIXME
:link ""
:edit-link ""
:edit-button-label "Edit"
:generic-commenter-name "Someone")))
(defprepared find-journal-articles
"SELECT article
FROM article_revisions
WHERE status IN ('published', 'syndicated')
GROUP BY article
HAVING EXISTS (SELECT 1 FROM article_aliases
WHERE article = article_revisions.article
AND alias LIKE 'journal/%')
ORDER BY min(date) DESC"
:column)
(defun find-journal-archive-request-handler (path full-p &optional action characteristics)
(declare (ignore action))
(when (or (string= path "journal")
(string= path "journal/"))
(lambda ()
(with-db
(let* ((articles (find-journal-articles))
;; XXX This is probably horriby inefficient. We may want
;; to try to get FIND-ARTICLE-REVISIONS into the
;; database as a view or at least a stored procedure.
(revisions (remove-if #'null
(mapcar (lambda (x)
(find-article-params x characteristics))
articles)))
(displayed-revisions (if full-p revisions (subseq revisions 0 10)))
(page-skeleton (template "page_skeleton"))
(page-template (template "journal_page"))
(template-params (list :title *site-name*
:root *base-uri*
:site-name *site-name*
:site-subtitle ""
:link ""
:full-archive-link ""
:full-archive-label "Full archive (slow!)"))
(head (expand-template page-template (list* :head t
:articles displayed-revisions
:minor-articles revisions
template-params)))
(body (expand-template page-template (list* :body t
:articles displayed-revisions
:minor-articles revisions
template-params))))
(expand-template page-skeleton (list :title *site-name*
:head head
:body body)))))))
(defun find-article-params (article characteristics &optional commentary-p)
(let* ((revisions (find-article-revisions article characteristics))
(comment-data (if commentary-p
(query "SELECT id FROM comments WHERE article = $1"
article
:column)
(list)))
(comment-revision-data
(remove-if #'null
(mapcar (lambda (cid)
(first
(query "SELECT *
FROM comment_revisions
WHERE comment = $1
AND status IN ('approved', 'trusted')
ORDER BY date DESC"
cid
:lists)))
comment-data)))
(comments (mapcar #'paramify-comment comment-revision-data))
(revision-data (first revisions)))
(cond ((null revision-data)
nil)
(commentary-p
(paramify-article revision-data comments))
(t
(paramify-article revision-data)))))
(defun find-article-request-handler (path &optional action characteristics)
(with-db
(when-let ((article (query "SELECT article FROM article_aliases
WHERE alias = $1"
path
:single)))
(lambda ()
(with-db
(let* ((page-template-name (query "SELECT page_template FROM articles
JOIN article_types
ON articles.type = article_types.id
WHERE articles.id = $1"
article
:single!))
(article-params (find-article-params article characteristics))
(page-skeleton (template "page_skeleton"))
(page-template (template page-template-name))
(template-params (list :title (getf article-params :title)
:root *base-uri*
:site-name *site-name*
:site-subtitle ""
:link ""))
(head (expand-template page-template (list* :head t
:articles (list article-params)
template-params)))
(body (expand-template page-template (list* :body t
:articles (list article-params)
template-params))))
(expand-template page-skeleton (list :title (getf article-params :title)
:head head
:body body))))))))
|
