◊(Local Yarn Code "Diff")

Differences From Artifact [87ac52b6]:

To Artifact [e8e2afa2]:


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
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







+











+
+
+
+
+
+
+







;; 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
         txexpr
         db/base
         "sqlite-tools.rkt"
         "snippets-html.rkt"
         "dust.rkt")

;; ~~~ Provides ~~~

(provide spell-of-summoning!
         crystalize-article!
         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
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
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







+










+
+
+
+
+
+




+
+
+







-
+













-
+



-
+


-
+



+
+



















-
+





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    note_id
    title_html_flow
    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))
  (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))
  
  (let* ([pubdate (select-from-metas 'published (current-metas))]
         [doc-html    (->html (cdr body-txpr))]
         [doc-html    (->html body-txpr #:splice? #t)]
         [title-specified? (not (equal? '() maybe-title))]
         [title-val   (if (not (null? maybe-title)) (car maybe-title) maybe-title)]
         [title-tx    (make-article-title title-val body-txpr disposition disp-note-id)]
         [title-html  (->html title-tx)]
         [title-html  (->html title-tx #:splice? #t)]
         [title-plain (tx-strs title-tx)]
         [series-node (series-pagenode)]
         [header      (html$-article-open title-specified? title-tx pubdate)]
         [header      (html$-article-open pagenode title-specified? title-tx pubdate)]
         [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)])

    (crystalize-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
            "")) ; listing_short_html: Not yet used
            (html$-article-listing-short pagenode pubdate title-plain))) ; 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)))

;; ~~~ 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` FROM `articles`
        UNION SELECT
        `~a`,`date` AS `published` 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 ~~~
;;

;; Return a title txexpr for the current article, constructing a default if no title text was specified.
(define (make-article-title supplied-title body-tx disposition disp-note-id)
  (define title-elems
    (cond [(null? supplied-title) (list (default-title (get-elements body-tx)))]
175
176
177
178
179
180
181
182

183
184
185
186
187
188
189
247
248
249
250
251
252
253

254
255
256
257
258
259
260
261







-
+







  
;; 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 s-title (series-title))
  (define s-noun (series-noun))
  (define series-part
    (cond [(non-empty-string? s-title)
           (format "This is ~a, part of <a href=\"/~a\">‘~a’</a>."
           (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))
198
199
200
201
202
203
204
205
206


207
208
209
210
211
212
213
270
271
272
273
274
275
276


277
278
279
280
281
282
283
284
285







-
-
+
+







                   pagenode
                   note-count)]
          [(and (note-count . > . 0) (string=? disposition ""))
           (format "There is <a href=\"/~a#furthernotes\">a note</a> appended."
                   pagenode)]
          [else ""]))
  
  (cond [(andmap non-empty-string? (list series-part disp-part notes-part))
         (format "~a ~a ~a" series-part disp-part notes-part)]
  (cond [(ormap non-empty-string? (list series-part disp-part notes-part))
         (string-join (list series-part disp-part notes-part))]
        [else ""]))
    

;; ~~~ Notes ~~~

;; Save a collection of ◊note tags to the DB, and return the HTML of the complete
;; “Further Notes” section at the end
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
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







-
+

-
+















+



















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







              (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 author (maybe-attr 'author attrs default-authorname))
  (define note-id (build-note-id note-tx))
  (define title-html-flow (html$-note-title author pagenode parent-title-plain))
  (define title-html-flow (html$-note-title 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 content-html author author-url))

  (define note-record
    (list pagenode
          note-id
          title-html-flow
          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 (article-plain-title pagenode)
  (query-value (sqltools:dbc) "SELECT `title_plain` FROM `articles` WHERE `pagenode` = ?1" (symbol->string pagenode)))

;; ~~~ Keyword Index Entries ~~~

;; (private) Save any index entries in doc to the cache
(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?))

  ; Naive idempotence: delete and re-insert all index entries every time doc is rendered.
  (query! "DELETE FROM `keywordindex` WHERE `pagenode` = ?1" (symbol->string pagenode))
  
  (unless (null? entries)
    (define entry-rows
      (for/list ([entry-tx (in-list entries)])
        (list (attr-ref entry-tx 'data-index-entry)
              "" ; subentries not yet implemented
              (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