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
|
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
|
+
-
+
+
+
+
+
+
-
+
+
-
-
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
-
+
-
+
-
-
-
+
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; will be coming from me.
(require pollen/setup
pollen/core
pollen/template
pollen/pagetree
racket/string
txexpr
"sqlite-tools.rkt"
"template-html.rkt"
"dates.rkt")
"dust.rkt")
;; ~~~ Provides ~~~
(provide spell-of-summoning!
crystalize-article!)
;; ~~~ Private use ~~~
(define DBFILE (build-path (current-project-root) "vitreous.sqlite"))
;; Since the DB exists to serve as a high-speed cache, the tables are constructed so that
;; the most commonly needed data can be grabbed quickly with extremely simple queries. In
;; the even that you want to do something fancy and custom rather than using the pre-cooked
;; HTML, enough info is provided in the other columns to allow you to do so.
;;
(define table_articles-fields
'(pagenode
title
title_plain
title_html_flow
published
updated
doc_html
note_count))
note_count
doc_html
disposition
disposition_note_id
listing_full_html ; Contains full content in default HTML format, but without notes
listing_excerpt_html ; Not used for now
listing_short_html)) ; Date and title only
(define table_notes-fields
'(pagenode
note-id
heading
note_id
title_html_flow
author
author_url
date
disposition
content_html
listing_full_html
listing_excerpt_html ; Not used for now
note_html))
listing_short_html))
(define table_series-fields
'(pagenode
title
published
noun_plural
noun_singular))
(define table_articles (make-table-schema "articles" table_articles-fields))
(define table_notes (make-table-schema "notes" table_notes-fields #:primary-key-cols '(pagenode note-id)))
(define table_notes (make-table-schema "notes" table_notes-fields #:primary-key-cols '(pagenode note_id)))
(define table_series (make-table-schema "series" table_series-fields))
(define (optional-meta m)
(or (select-from-metas m (current-metas)) ""))
(define (doc->body/notes doc)
(define (is-note? tx) (and (txexpr? tx) (equal? 'note (get-tag tx))))
(splitf-txexpr doc is-note?))
(define (series-noun)
(define series-pagenode (->pagenode (or (select-from-metas 'series (current-metas)) "")))
(case series-pagenode
['|| ""] ; no series specified
[else (or (select-from-metas 'noun-singular series-pagenode) "")]))
;; Save an article (using current-doc and current-metas) and its notes (if any)
;; to the database, and return the rendered HTML.
;; Save an article and its notes (if any) to the database, and return the
;; rendered HTML of the complete article.
;;
(define (crystalize-article! pagenode doc)
(define pubdate (select-from-metas 'published (current-metas)))
(define-values (body-txpr note-txprs) (doc->body/notes doc))
(define doc-html (->html (cdr body-txpr)))
(define-values (disposition disp-note-id)
(notes->last-disposition-values note-txprs))
(define-values (title-plain title-html-flow)
(make-article-titles (maybe-meta 'title (default-title pubdate)) (report disposition)))
(define header (html-article-header))
(define footer (html-article-footer))
(define body (->html (cdr doc)))
;; TK: store notes separately
(define header (html$-article-open title-html-flow pubdate))
(define footer (html$-article-close))
(define notes-section-html (crystalize-notes! pagenode title-plain note-txprs))
;; Values must come in the order defined in table_article_fields
(define article-record
(list (symbol->string pagenode)
title-plain
title-html-flow
pubdate
(maybe-meta 'updated)
(maybe-meta 'author default-authorname)
(maybe-meta 'conceal)
(maybe-meta 'series)
(maybe-meta 'noun (series-noun))
(length note-txprs)
doc-html
disposition
disp-note-id
(string-append header doc-html footer)
"" ; listing_excerpt_html: Not yet used
"")) ; listing_short_html: Not yet used
(apply query! (make-insert/replace-query 'articles table_articles-fields) article-record)
◊string-append{◊header ◊doc-html ◊notes-section-html ◊footer})
(define (make-article-titles title-val disposition)
(define disposition-part
(cond [(non-empty-string? disposition)
(define-values (mark _) (disposition-values disposition))
(format "<span class=\"disposition-mark\">~a</span>" mark)]
[else ""]))
(cond [(txexpr? title-val)
(values (apply string-append (tx-strs title-val))
(string-append (->html title-val) disposition-part))]
[else (values title-val (string-append title-val disposition-part))]))
(define (crystalize-notes! pagenode parent-title note-txprs)
(define (crystalizer note-tx)
(crystalize-note! note-tx (symbol->string pagenode) parent-title))
(cond [((length note-txprs) . > . 0)
(define notes-html (map crystalizer note-txprs))
(html$-notes-section notes-html)]
[else ""]))
(define (crystalize-note! note-tx pagenode parent-title-plain)
(define-values (_ attrs elems) (txexpr->values note-tx))
(define disposition-attr (maybe-attr 'disposition attrs))
(define saving-query (make-insert/replace-query 'articles table_articles-fields))
(query! saving-query
(symbol->string pagenode)
(optional-meta 'title)
(select-from-metas 'published (current-metas))
(optional-meta 'updated)
(string-append header body footer)
(optional-meta 'author)
(optional-meta 'conceal)
(optional-meta 'series)
(define note-date (maybe-attr 'date attrs))
;; Check required attributes
(unless (non-empty-string? note-date)
(raise-arguments-error 'note "required attr missing: date" "attrs" attrs))
(unless (or (string=? "" disposition-attr)
(and ((length (string-split disposition-attr)) . >= . 2)))
(raise-arguments-error 'note
"must be in format \"[symbol] [past-tense-verb]\""
"disposition attr"
disposition-attr))
;; Parse out remaining columns
(define author (maybe-attr 'author attrs))
(define note-id (build-note-id note-tx))
(define title-html-flow (html$-note-title author pagenode parent-title-plain))
(define author-url (maybe-attr 'author-url attrs))
(define-values (disp-mark disp-verb) (disposition-values disposition-attr))
(define content-html (html$-note-contents disp-mark (get-elements note-tx)))
(define listing-full-html
(html$-note-listing-full pagenode note-id title-html-flow note-date author author-url content-html))
(define note-record
(list pagenode
note-id
title-html-flow
author
author-url
note-date
disposition-attr
content-html
(series-noun)
0) ; note_count
`(@ ,header ,body ,footer))
|
