blob: 60475ec97afad519498f7caee913f8ff89412873 (
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
|
(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-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-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")))
(defun find-mulkcms-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!))
(revisions (find-article-revisions article characteristics))
(comment-data (query "SELECT id FROM comments WHERE article = $1"
article
:column))
(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))
(page-skeleton (template "page_skeleton"))
(page-template (template page-template-name))
(template-params (list :title (fourth revision-data)
:root *base-uri*
:site-name *site-name*
:site-subtitle ""
:link ""))
(article-params (paramify-article revision-data comments))
(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 (fourth revision-data)
:head head
:body body))))))))
|
