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
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
|
#lang racket/base
; SPDX-License-Identifier: BlueOak-1.0.0
; This file is licensed under the Blue Oak Model License 1.0.0.
;; Provides functions for fast preserving and fetching of article/series data.
;; → Docs and metas go in (saved to SQLite database)
;; HTML comes out →
;; Calling sites have no notion of the database or schema.
;; The functions provided by sqlite-tools.rkt are not safe for user-provided
;; data; a maliciously crafted input could bomb the database. This is acceptable
;; since the database is merely a disposable cache, and since all the input
;; will be coming from me.
(require pollen/setup
pollen/core
pollen/template
racket/string
racket/function
racket/list
txexpr
db/base
"sqlite-tools.rkt"
"snippets-html.rkt"
"dust.rkt")
;; ~~~ Provides ~~~
(provide spell-of-summoning!
crystalize-article!
crystalize-series!
crystalize-index-entries!
article-plain-title
list/articles
list/articles+notes
listing<>-short/articles
listing<>-full/articles
listing<>-full/articles+notes
unfence
sqltools:dbc
preheat-series!)
;; ~~~ 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_plain
title_html_flow
title_specified
published
updated
author
conceal
series_pagenode
noun_singular
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
title_html_flow
title_plain
author
author_url
date
disposition
content_html
series_pagenode
listing_full_html
listing_excerpt_html ; Not used for now
listing_short_html))
(define table_series-fields
'(pagenode
title
published
noun_plural
noun_singular))
(define table_keywordindex-fields
'(entry
subentry
pagenode
anchor))
(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_series (make-table-schema "series" table_series-fields))
(define table_keywordindex (make-table-schema "keywordindex"
table_keywordindex-fields
#:primary-key-cols '(pagenode anchor)))
;; ~~~ Provided functions: Initializing; Saving posts and notes
;; Initialize the database connection, creating the database if it doesn’t
;; exist, and executing the table schema queries
;;
(define (spell-of-summoning!)
(init-db! DBFILE table_articles table_notes table_series table_keywordindex))
;; 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-values
(doc2 maybe-title) (splitf-txexpr doc (make-tag-predicate 'title)))
(define-values
(body-txpr note-txprs) (splitf-txexpr doc2 (make-tag-predicate 'note)))
(define-values (disposition disp-note-id)
(notes->last-disposition-values note-txprs))
[series-node (series-pagenode)]
[footertext (make-article-footertext pagenode series-node disposition disp-note-id (length note-txprs))]
[footer (html$-article-close footertext)]
[notes-section-html (crystalize-notes! pagenode title-plain note-txprs)])
rystalize-index-entries! pagenode doc) ; Note the original doc is used here
;; Values must come in the order defined in table_article_fields
(define article-record
(list (symbol->string pagenode)
title-plain
title-html
(bool->int title-specified?)
pubdate
(maybe-meta 'updated)
(maybe-meta 'author default-authorname)
(maybe-meta 'conceal)
(symbol->string series-node)
(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
(html$-article-listing-short pagenode pubdate title-html)))
(apply query! (make-insert/replace-query 'articles table_articles-fields) article-record)
(string-append header doc-html notes-section-html footer)))
;; ~~~ Retrieve listings of articles and notes ~~~
;; ~~~ (Mainly for use on Series pages ~~~
;; (private) Create a WHERE clause matching a single series or list of series
(define (where/series s)
(cond [(list? s)
(let ([series (map (curry (format "~a/~a.html" series-folder)) s)])
(format "WHERE `series_pagenode` IN ~a" (list->sql-values series)))]
[(string? s)
(format "WHERE `series_pagenode` IS \"~a/~a.html\"" series-folder s)]
[(equal? s #t)
(format "WHERE `series_pagenode` IS \"~a\"" (here-output-path))]
[else ""]))
;; Return a combined list of articles and notes sorted by date
(define (list/articles+notes type #:series [s #t] #:limit [limit -1] [order "DESC"])
(define select #<<@@@@@
SELECT `~a` FROM
(SELECT `~a`, `published`, `series_pagenode` FROM `articles`
UNION SELECT
`~a`,`date` AS `published`, `series_pagenode` FROM `notes`)
~a ORDER BY `published` ~a LIMIT ~a
@@@@@
)
(query-list (sqltools:dbc) (format select type type type (where/series s) order limit)))
;; Return a list of articles only, sorted by date
(define (list/articles type #:series [s #t] #:limit [limit -1] [order "DESC"])
(define select "SELECT `~a` FROM `articles` ~a ORDER BY `published` ~a LIMIT ~a")
(query-list (sqltools:dbc) (format select type (where/series s) order limit)))
;; ~~~~
;; Return cached HTML of articles and/or notes, fenced within a style txexpr to prevent it being
;; escaped by ->html. See also: definition of `unfence`
(define (listing<>-short/articles #:series [s #t] #:limit [limit -1] [order "DESC"])
`(style "<ul class=\"article-list\">"
,@(list/articles "listing_short_html" #:series s #:limit limit order)
"</ul>"))
(define (listing<>-full/articles #:series [s #t] #:limit [limit -1] [order "DESC"])
`(style ,@(list/articles "listing_full_html" #:series s #:limit limit order)))
;; Return a combined list of articles and notes (“full content” version) sorted by date
(define (listing<>-full/articles+notes #:series [s #t] #:limit [limit -1] [order "DESC"])
`(style ,@(list/articles+notes "listing_full_html" #:series s #:limit limit order)))
;; Remove "<style>" and "</style>" introduced by using ->html on docs containing output from
;; listing functions
(define (unfence html-str)
(regexp-replace* #px"<[\\/]{0,1}style>" html-str ""))
;; ~~~ Article-related helper functions ~~~
;;
;; If the first element is a titled poem, the poem’s title can be used for the article title.
(define (check-for-poem-title doc)
(define e1 (car (get-elements doc)))
(define e2 (if (null? (get-elements e1))
'()
(car (get-elements e1))))
(cond
[(and (txexpr? e1)
(equal? 'div (get-tag e1))
(attrs-have-key? e1 'class)
(string=? "poem" (attr-ref e1 'class))
(not (null? e2))
(txexpr? e2)
(equal? 'p (get-tag e2))
(attrs-have-key? e2 'class)
(string=? "verse-heading" (attr-ref e2 'class)))
`(title (span [[class "smallcaps"]] "‘" ,@(get-elements e2) "’"))]
[else '()]))
;; Return a title txexpr for the current article, constructing a default if no title text was specified.
(define (make-article-title pagenode supplied-title body-tx disposition disp-note-id)
(define title-elems
(cond [(null? supplied-title) (list (default-title (get-elements body-tx)))]
[else (get-elements supplied-title)]))
(define disposition-part
(cond [(non-empty-string? disposition)
(define-values (mark _) (disposition-values disposition))
`(a [[class "disposition-mark"]
[href ,(format "~a~a#~a" web-root pagenode disp-note-id)]]
,mark)]
[else ""]))
;; Returns a txexpr, the tag will be discarded by the template/snippets
`(title ,@title-elems ,disposition-part))
(define s-title (series-title))
(define s-noun (series-noun))
(cond [(non-empty-string? s-title)
(format "<span class=\"series-part\">This is ~a, part of <a href=\"/~a\">‘~a’</a>.</span>"
s-noun
series
s-title)]
[else ""]))
(define disp-part
(cond [(non-empty-string? disposition)
(define-values (mark verb) (disposition-values disposition))
(format "Now considered <a href=\"/~a#~a\">~a</a>."
pagenode
disp-note-id
verb)]
|
<
<
<
<
|
<
<
<
<
|
>
|
<
<
<
<
>
|
|
|
<
|
|
<
|
|
<
|
>
>
>
>
|
|
|
|
>
|
|
<
<
|
>
<
|
|
<
<
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
>
|
|
|
|
<
<
|
|
|
|
|
<
<
<
<
|
>
>
|
>
|
|
|
|
|
|
<
>
|
>
>
>
>
>
|
<
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
|
<
|
<
<
|
<
|
|
>
|
|
|
<
<
>
|
|
|
|
|
|
|
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
|
#lang racket/base
; SPDX-License-Identifier: BlueOak-1.0.0
; This file is licensed under the Blue Oak Model License 1.0.0.
(require deta db/base db/sqlite3 threading txexpr gregor)
(require racket/match
racket/string
pollen/pagetree
pollen/template
(except-in pollen/core select) ; avoid conflict with deta
pollen/setup)
(require "dust.rkt" "snippets-html.rkt")
(provide init-cache-db!
cache-conn ; The most eligible bachelor in Neo Yokyo
parse-and-cache-article!
cache-series!
current-plain-title
(schema-out cache:article)
(schema-out cache:note)
(schema-out cache:series)
(schema-out cache:index-entry)
articles
articles+notes
listing-htmls
<listing-full>
<listing-excerpt>
<listing-short>
unfence)
;; Cache DB and Schemas
(define DBFILE (build-path (current-project-root) "vitreous.sqlite"))
(define cache-conn (sqlite3-connect #:database DBFILE #:mode 'create))
(define current-plain-title (make-parameter "void"))
(define-schema cache:article #:table "articles"
([id id/f #:primary-key #:auto-increment]
[page symbol/f]
[title-plain string/f]
[title-html-flow string/f]
[title-specified? boolean/f]
[published string/f]
[updated string/f]
[author string/f]
[conceal string/f]
[series-page symbol/f]
[noun-singular string/f]
[note-count integer/f]
[doc-html string/f]
[disposition string/f]
[disp-html-anchor string/f]
[listing-full-html string/f] ; full content but without notes
[listing-excerpt-html string/f] ; Not used for now
[listing-short-html string/f])) ; Date and title only
(define-schema cache:note #:table "notes"
([id id/f #:primary-key #:auto-increment]
[page symbol/f]
[html-anchor string/f]
[title-html-flow string/f] ; No block-level HTML elements
[title-plain string/f]
[author string/f]
[author-url string/f]
[published string/f]
[disposition string/f]
[content-html string/f]
[series-page symbol/f]
[listing-full-html string/f]
[listing-excerpt-html string/f] ; Not used for now
[listing-short-html string/f])) ; Date and title only
(define-schema cache:series #:table "series"
([id id/f #:primary-key #:auto-increment]
[page symbol/f]
[title string/f]
[published string/f]
[noun-plural string/f]
[noun-singular string/f]))
(define-schema cache:index-entry #:table "index_entries"
([id id/f #:primary-key #:auto-increment]
[entry string/f]
[subentry string/f]
[page symbol/f]
[html-anchor string/f]))
(define-schema listing
#:virtual
([html string/f]
[published date/f]
[series-page symbol/f]))
(define (init-cache-db!)
(create-table! cache-conn 'cache:article)
(create-table! cache-conn 'cache:note)
(create-table! cache-conn 'cache:series)
(create-table! cache-conn 'cache:index-entry))
;; Save an article and its notes (if any) to the database, and return the
;; rendered HTML of the complete article.
;;
(define (parse-and-cache-article! pagenode doc)
(define-values (doc-no-title maybe-title)
(splitf-txexpr doc (make-tag-predicate 'title)))
(define-values (body-txpr note-txprs)
(splitf-txexpr doc-no-title (make-tag-predicate 'note)))
(define-values (disposition disp-note-id)
(notes->last-disposition-values note-txprs))
(let* ([pubdate (select-from-metas 'published (current-metas))]
[doc-html (->html body-txpr #:splice? #t)]
[title-specified? (not (equal? '() maybe-title))]
[title-val (if (not (null? maybe-title)) (car maybe-title) (check-for-poem-title doc))]
[title-tx (make-article-title pagenode title-val body-txpr disposition disp-note-id)]
[title-html (->html title-tx #:splice? #t)]
[title-plain (tx-strs title-tx)]
[header (html$-article-open pagenode title-specified? title-tx pubdate)]
[series-node (metas-series-pagenode)]
[footertext (make-article-footertext pagenode
series-node
disposition
disp-note-id
(length note-txprs))]
[footer (html$-article-close footertext)]
[listing-short (html$-article-listing-short pagenode pubdate title-html)]
[notes-section-html (cache-notes! pagenode title-plain note-txprs)])
(cache-index-entries! pagenode doc) ; note original doc is used here
(current-plain-title title-plain)
(insert-one! cache-conn
(make-cache:article
#:page pagenode
#:title-plain title-plain
#:title-html-flow title-html
#:title-specified? title-specified?
#:published pubdate
#:updated (maybe-meta 'updated)
#:author (maybe-meta 'author default-authorname)
#:conceal (maybe-meta 'conceal)
#:series-page series-node
#:noun-singular (maybe-meta 'noun (series-metas-noun))
#:note-count (length note-txprs)
#:doc-html doc-html
#:disposition disposition
#:disp-html-anchor disp-note-id
#:listing-full-html (string-append header doc-html footer)
#:listing-excerpt-html ""
#:listing-short-html listing-short))
(string-append header doc-html notes-section-html footer)))
(define (check-for-poem-title doc-txpr)
(match (car (get-elements doc-txpr))
[(txexpr 'div
(list (list 'class "poem"))
(list* (txexpr 'p
(list (list 'class "verse-heading"))
heading-elems)
_))
`(title (span [[class "smallcaps"]] "‘" ,@heading-elems "’"))]
[_ '()]))
;; Return a title txexpr for the current article, constructing a default if no title text was specified.
(define (make-article-title pagenode supplied-title body-tx disposition disp-note-id)
(define title-elems
(cond [(null? supplied-title) (list (default-title (get-elements body-tx)))]
[else (get-elements supplied-title)]))
(define disposition-part
(cond [(non-empty-string? disposition)
(define-values (mark _) (disposition-values disposition))
`(a [[class "disposition-mark"]
[href ,(format "~a~a#~a" web-root pagenode disp-note-id)]]
,mark)]
[else ""]))
;; Returns a txexpr, the tag will be discarded by the template/snippets
`(title ,@title-elems ,disposition-part))
;; Convert a bunch of information about an article into some nice English and links.
(define (make-article-footertext pagenode series disposition disp-note-id note-count)
(define series-part
(match (series-metas-title)
[(? non-empty-string? s-title)
(format "<span class=\"series-part\">This is ~a, part of <a href=\"/~a\">‘~a’</a>.</span>"
(series-metas-noun)
series
s-title)]
[_ ""]))
(define disp-part
(cond [(non-empty-string? disposition)
(define-values (mark verb) (disposition-values disposition))
(format "Now considered <a href=\"/~a#~a\">~a</a>."
pagenode
disp-note-id
verb)]
|
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
|
(format "There is <a href=\"/~a#furthernotes\">a note</a> appended."
pagenode)]
[else ""]))
(cond [(ormap non-empty-string? (list series-part disp-part notes-part))
(string-join (list series-part disp-part notes-part))]
[else ""]))
;; Save a collection of ◊note tags to the DB, and return the HTML of the complete
;; “Further Notes” section at the end
;;
(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 ""]))
;; Save an individual note to the DB and return the HTML of the complete note as
;; it should appear on an individual article page
;;
(define (crystalize-note! note-tx pagenode parent-title-plain)
(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 default-authorname))
(define note-id (build-note-id note-tx))
(define title-tx (make-note-title pagenode parent-title-plain))
(define title-html-flow (->html title-tx #:splice? #t))
(define title-plain (tx-strs title-tx))
(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 disp-verb (get-elements note-tx)))
(define listing-full-html
(html$-note-listing-full pagenode note-id title-html-flow note-date content-html author author-url))
(define note-record
(list pagenode
note-id
title-html-flow
title-plain
author
author-url
note-date
disposition-attr
content-html
(symbol->string (series-pagenode))
listing-full-html
"" ; listing_excerpt_html: Not used for now
"")) ; listing_short_html: Not used for now
;; save to db
(define save-note-query
(format (string-append "INSERT OR REPLACE INTO `notes` (`rowid`, ~a) "
"VALUES ((SELECT `rowid` FROM `notes` WHERE `pagenode` = ?1"
" AND `note_id` = ?2), ~a)")
(list->sql-fields table_notes-fields)
(list->sql-parameters table_notes-fields)))
(apply query! save-note-query note-record)
;; return html$ of note
(html$-note-in-article note-id note-date content-html author author-url))
(define (make-note-title pagenode parent-title-plain)
`(note-title "Re: " (a [[class "cross-reference"]
[href ,(format "~a~a" web-root pagenode)]]
,parent-title-plain)))
(define (article-plain-title pagenode)
(query-value (sqltools:dbc) "SELECT `title_plain` FROM `articles` WHERE `pagenode` = ?1" (symbol->string pagenode)))
;; Save any index entries in doc to the SQLite cache.
;; Sub-entries are specified by "!" in the index key
(define (crystalize-index-entries! pagenode doc)
(define (index-entry? tx)
(and (txexpr? tx)
(string=? "index-link" (attr-ref tx 'class "")) ; see definition of html-index
(attr-ref tx 'data-index-entry #f)))
(define-values (_ entries) (splitf-txexpr doc index-entry?))
(query! "DELETE FROM `keywordindex` WHERE `pagenode` = ?1" (symbol->string pagenode))
(unless (null? entries)
(define entry-rows
(for/list ([entry-tx (in-list entries)])
(define entry-parts (split-entry (attr-ref entry-tx 'data-index-entry)))
(list (first entry-parts)
(second entry-parts)
(symbol->string pagenode)
(attr-ref entry-tx 'id))))
(query! (make-insert-rows-query "keywordindex" table_keywordindex-fields entry-rows))))
;; ~~~ Series ~~~
;; Preloads the SQLite cache with info about each series.
;; I may not actually need this but I’m leaving it for now.
(define (preheat-series!)
(query! "DELETE FROM `series`")
(define series-values
(for/list ([series-pagenode (in-list (cdr (series-pagetree)))])
(define series-metas (get-metas series-pagenode))
(list (symbol->string series-pagenode)
(hash-ref series-metas 'title)
(hash-ref series-metas 'published)
(hash-ref series-metas 'noun-plural "")
(hash-ref series-metas 'noun-singular ""))))
(define sql$-insert (make-insert-rows-query 'series table_series-fields series-values))
(displayln sql$-insert)
(query! sql$-insert))
(define (crystalize-series!)
(define series-row
(list (path->string (here-output-path))
(hash-ref (current-metas) 'title)
(hash-ref (current-metas) 'published "")
(hash-ref (current-metas) 'noun-plural "")
(hash-ref (current-metas) 'noun-singular "")))
(apply query! (make-insert/replace-query 'series table_series-fields) series-row))
|
<
<
<
<
|
<
>
|
|
<
|
>
>
|
<
|
|
|
<
<
|
|
|
<
>
|
<
|
<
<
|
|
|
|
|
|
>
|
|
<
|
>
|
<
|
<
<
|
<
>
|
<
<
|
<
<
<
|
>
|
>
|
<
<
<
<
<
<
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
>
|
|
|
|
>
>
>
|
>
>
>
>
>
>
>
>
>
|
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
|
<
>
>
|
>
>
>
>
|
>
|
>
>
>
|
>
|
>
|
|
>
>
|
>
>
>
>
|
>
>
>
|
>
>
>
>
|
>
|
<
>
>
|
<
|
>
>
>
>
>
>
>
|
|
|
|
<
|
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
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
|
(format "There is <a href=\"/~a#furthernotes\">a note</a> appended."
pagenode)]
[else ""]))
(cond [(ormap non-empty-string? (list series-part disp-part notes-part))
(string-join (list series-part disp-part notes-part))]
[else ""]))
;; ~~~ Notes ~~~
(define (cache-notes! pagenode parent-title note-txprs)
(query-exec cache-conn (delete (~> (from cache:note #:as n)
(where (= n.page ,(symbol->string pagenode))))))
(cond [(not (null? note-txprs))
(define note-htmls
(for/list ([n (in-list note-txprs)])
(cache-note! n pagenode parent-title)))
(html$-notes-section note-htmls)]
[else ""]))
;; Save an individual note to the DB and return the HTML of the complete note as
;; it should appear on an individual article page
(define (cache-note! note-tx pagenode parent-title-plain)
(define-values (_ attrs elems) (txexpr->values note-tx))
(define disposition-attr (maybe-attr 'disposition attrs))
(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)
(>= (length (string-split disposition-attr)) 2))
(raise-arguments-error 'note
"must be in format \"[symbol] [past-tense-verb]\""
"disposition attr"
disposition-attr))
(define-values (disp-mark disp-verb) (disposition-values disposition-attr))
(let* ([note-id (build-note-id note-tx)]
[title-tx (make-note-title pagenode parent-title-plain)]
[title-html (->html title-tx #:splice? #t)]
[author (maybe-attr 'author attrs default-authorname)]
[author-url (maybe-attr 'author-url attrs)]
[content-html (html$-note-contents disp-mark disp-verb elems)])
(insert-one! cache-conn
(make-cache:note
#:page pagenode
#:html-anchor note-id
#:title-html-flow title-html
#:title-plain (tx-strs title-tx)
#:published note-date
#:author author
#:author-url author-url
#:disposition disposition-attr
#:series-page (metas-series-pagenode)
#:content-html content-html
#:listing-full-html (html$-note-listing-full pagenode
note-id
title-html
note-date
content-html
author
author-url)
#:listing-excerpt-html ""
#:listing-short-html ""))
(html$-note-in-article note-id note-date content-html author author-url)))
(define (make-note-title pagenode parent-title-plain)
`(note-title "Re: " (a [[class "cross-reference"]
[href ,(format "~a~a" web-root pagenode)]]
,parent-title-plain)))
;; ~~~ Keyword Index Entries ~~~
;; (private) Convert an entry key into a list of at most two elements,
;; a main entry and a sub-entry.
;; "entry" → '("entry" "")
;; "entry!sub" → '("entry" "sub")
;; "entry!sub!why?!? '("entry" "sub")
(define (split-entry str)
(define splits (string-split str "!"))
(list (car splits)
(cadr (append splits (list "")))))
(define (index-entry-txpr? tx)
(and (txexpr? tx)
(string=? "index-link" (attr-ref tx 'class "")) ; see definition of html-index
(attr-ref tx 'data-index-entry #f)))
(define (txexpr->index-entry tx pagenode)
(match (split-entry (attr-ref tx 'data-index-entry))
[(list main sub)
(make-cache:index-entry
#:entry main
#:subentry sub
#:page pagenode
#:html-anchor (attr-ref tx 'id))]))
;; Save any index entries in doc to the SQLite cache.
;; Sub-entries are specified by "!" in the index key
(define (cache-index-entries! pagenode doc)
(define-values (_ entry-txs) (splitf-txexpr doc index-entry-txpr?))
; Naive idempotence: delete and re-insert all index entries every time doc is rendered.
(query-exec cache-conn (delete (~> (from cache:index-entry #:as entry)
(where (= entry.page ,(symbol->string pagenode))))))
(unless (null? entry-txs)
(void
(apply insert! cache-conn
(for/list ([etx (in-list entry-txs)])
(txexpr->index-entry etx pagenode))))))
;;
;; ~~~ Fetching articles and notes ~~~
;;
;; (Private use) Conveniece function for the WHERE `series-page` clause
(define (where-series q s)
(define (s->p x) (format "~a/~a.html" series-folder x))
(match s
[(list series ...)
(where q (in a.series-page ,(map s->p series)))] ; WHERE series-page IN (item1 ...)
[(or (? string? series) (? symbol? series))
(where q (= a.series-page ,(s->p series)))] ; WHERE series-page = "item"
[#t
(where q (= a.series-page ,(path->string (here-output-path))))]
[_ q]))
;; Needed to "parameterize" column names
;; see https://github.com/Bogdanp/deta/issues/14#issuecomment-573344928
(require (prefix-in ast: deta/private/ast))
;; Builds a query to fetch articles
(define (articles type #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
(define html-field (format "listing_~a_html" type))
(~> (from cache:article #:as a)
(select (fragment (ast:as (ast:qualified "a" html-field) "html"))
a.published
a.series-page)
(where-series s)
(limit ,lim)
(order-by ([a.published ,ord]))
(project-onto listing-schema)))
;; Builds a query that returns articles and notes intermingled chronologically
(define (articles+notes type #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
(define html-field (format "listing_~a_html" type))
(~> (from (subquery
(~> (from cache:article #:as A)
(select (fragment (ast:as (ast:qualified "A" html-field) "html"))
A.published
A.series-page)
(union
(~> (from cache:note #:as N)
(select (fragment (ast:as (ast:qualified "N" html-field) "html"))
N.published
N.series-page)))))
#:as a)
(where-series s)
(limit ,lim)
(order-by ([a.published ,ord]))
(project-onto listing-schema)))
;; Get all the a list of the HTML all the results in a query
(define (listing-htmls list-query)
(for/list ([l (in-entities cache-conn list-query)])
(listing-html l)))
;; Return cached HTML of articles and/or notes, fenced within a style txexpr to prevent it being
;; escaped by ->html. See also: definition of `unfence`
;; E.g.: (<listing-full> articles+notes)
(define (<listing-full> query-func #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
`(style ,@(listing-htmls (query-func 'full #:series s #:limit lim #:order ord))))
;; ^^^^^
(define (<listing-excerpt> query-func #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
`(style ,@(listing-htmls (query-func 'excerpt #:series s #:limit lim #:order ord))))
;; ^^^^^^^^
(define (<listing-short> query-func #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
`(style "<ul class=\"article-list\">"
,@(listing-htmls (query-func 'short #:series s #:limit lim #:order ord))
"</ul>")) ;; ^^^^^^
;; Remove "<style>" and "</style>" introduced by using ->html on docs containing output from
;; listing functions
(define (unfence html-str)
(regexp-replace* #px"<[\\/]{0,1}style>" html-str ""))
;; Save the current article to the `series` table of the SQLite cache
;; Should be called from a template for series pages
(define (cache-series!)
(define here-page (path->string (here-output-path)))
(query-exec cache-conn
(delete (~> (from cache:series #:as s)
(where (= s.page ,here-page)))))
(void
(insert-one! cache-conn
(make-cache:series
#:page (string->symbol here-page)
#:title (hash-ref (current-metas) 'title)
#:published (hash-ref (current-metas) 'published "")
#:noun-plural (hash-ref (current-metas) 'noun-plural "")
#:noun-singular (hash-ref (current-metas) 'noun-singular "")))))
|
