#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))
(define (delete-article! page)
(query-exec cache-conn
(~> (from cache:article #:as a)
(where (= a.page ,(format "~a" page)))
delete)))
(define (delete-notes! page)
(query-exec cache-conn
(~> (from cache:note #:as n)
(where (= n.page ,(format "~a" page)))
delete)))
;; 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)
(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)
#: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)]
[else ""]))
(define notes-part
(cond [(note-count . > . 1)
(format "There are <a href=\"/~a#furthernotes\">~a notes</a> appended."
pagenode
note-count)]
[(and (note-count . > . 0) (string=? disposition ""))
(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 "")))))
