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
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
-
-
-
-
+
-
-
-
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
-
+
-
+
-
-
-
-
+
+
+
+
|
#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
threading
racket/match
racket/string
txexpr
pollen/template
pollen/decode
(except-in pollen/core select) ; avoid conflict with deta
)
(require "dust.rkt" "cache.rkt" "snippets-html.rkt")
(provide parse-and-cache-article!
cache-series!)
(define current-title (make-parameter #f))
(define current-excerpt (make-parameter #f))
(define current-notes (make-parameter '()))
(define current-disposition (make-parameter ""))
(define current-disp-id (make-parameter ""))
(define (filter-special-tags tx)
(match (get-tag tx)
['title (current-title tx) ""]
['excerpt (current-excerpt tx) ""]
['excerpt* (current-excerpt tx) `(@ ,@(get-elements tx))] ; splice contents back in
['note
(define note-id (build-note-id tx))
(cond [(attrs-have-key? tx 'disposition)
(current-disp-id note-id)
(current-disposition (attr-ref tx 'disposition))])
(current-notes (cons (attr-set tx 'note-id note-id) (current-notes))) ""]
[_ tx]))
;; Save an article and its notes (if any) to the database, and return
;; (values plain-title [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))
[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-specified? (if (current-title) #t #f)]
[title-val (or (current-title) (check-for-poem-title doc))]
[title-tx (make-article-title pagenode
title-val
body-txpr
(current-disposition)
(current-disp-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))]
(current-disposition)
(current-disp-id)
(length (current-notes)))]
[footer (html$-article-close footertext)]
[listing-short (html$-article-listing-short pagenode pubdate title-html)]
[listing-full (string-append header doc-html footer)]
[listing-excerpt (match (current-excerpt)
[#f listing-full]
[(var e) (string-append header (html$-article-excerpt pagenode e) footer)])]
[notes-section-html (cache-notes! pagenode title-plain note-txprs)])
[notes-section-html (cache-notes! pagenode title-plain (current-notes))])
(cache-index-entries! pagenode doc) ; note original doc is used here
(delete-article! pagenode)
(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)
#:note-count (length (current-notes))
#:content-html doc-html
#:disposition disposition
#:disp-html-anchor disp-note-id
#:listing-full-html (string-append header doc-html footer)
#:listing-excerpt-html ""
#:disposition (current-disposition)
#:disp-html-anchor (current-disp-id)
#:listing-full-html listing-full
#:listing-excerpt-html listing-excerpt
#:listing-short-html listing-short))
(values title-plain (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"))
|
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
|
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
|
-
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
-
-
+
|
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)])
[content-html (html$-note-contents disp-mark disp-verb elems)]
[listing-full (html$-note-listing-full pagenode
note-id
title-html
note-date
content-html
author
author-url)])
(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)
#:conceal (or (maybe-attr 'conceal attrs #f) (maybe-meta 'conceal))
#:content-html content-html
#:listing-full-html (html$-note-listing-full pagenode
#:listing-full-html listing-full
note-id
title-html
note-date
content-html
author
author-url)
#:listing-excerpt-html ""
|
