#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
pollen/setup
racket/match
(rename-in racket/list
(group-by group-list-by))
"dust.rkt"
(except-in pollen/core select))
(provide init-cache-db!
cache-conn ; The most eligible bachelor in Neo Yokyo
(schema-out cache:article)
(schema-out cache:note)
(schema-out cache:series)
(schema-out cache:index-entry)
(schema-out listing)
delete-article!
delete-notes!
articles
articles+notes
listing-htmls
fenced-listing
unfence
preheat-series!
series-grouped-list)
;; Cache DB and Schemas
(define DBFILE (build-path (current-project-root) "vitreous.sqlite"))
(define cache-conn (make-parameter (sqlite3-connect #:database DBFILE #:mode 'create)))
(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]
[content-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]
[conceal string/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
([path string/f]
[title string/f]
[author string/f]
[published string/f]
[updated string/f]
[html string/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)))
;;
;; ~~~ 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 (like a.series-page ,(format "%~a" (here-output-path))))]
[_ q]))
;; (Private use) Convenience for the WHERE `conceal` NOT LIKE clause
(define (where-not-concealed q)
(define base-clause (where q (not (like a.conceal "%all%"))))
(match (listing-context)
["" base-clause]
[(var context) (where base-clause (not (like a.conceal ,(format "%~a%" context))))]))
;; 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
(match type
['content "content_html"]
[_ (format "listing_~a_html" type)]))
(~> (from cache:article #:as a)
(select (as a.page path)
(as a.title-plain title)
a.author
a.published
a.updated
(fragment (ast:as (ast:qualified "a" html-field) "html")))
(where-series s)
(where-not-concealed)
(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
(match type
['content "content_html"]
[_ (format "listing_~a_html" type)]))
(~> (from (subquery
(~> (from cache:article #:as A)
(select
(as A.page path)
(as A.title-plain title)
A.author
A.published
A.updated
(fragment (ast:as (ast:qualified "A" html-field) "html"))
A.series-page
A.conceal)
(union
(~> (from cache:note #:as N)
(select
(as (array-concat N.page "#" N.html-anchor) path)
(as N.title-plain title)
N.author
N.published
(as "" updated)
(fragment (ast:as (ast:qualified "N" html-field) "html"))
N.series-page
N.conceal)))))
#:as a)
(where-series s)
(where-not-concealed)
(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`
(define (fenced-listing q)
`(style ,@(listing-htmls q)))
;; 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 ""))
;;
;; ~~~ Fetching series ~~~
;;
(define (series-grouped-list)
(~> (for/list ([row (in-entities (cache-conn)
(order-by (from cache:series #:as s)
([s.noun-plural #:asc])))]) row)
(group-list-by cache:series-noun-plural _ string-ci=?)))
;; 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-exec (cache-conn)
(~> (from cache:series #:as s)
(where 1)
delete))
(define series-rows
(for/list ([series-pagenode (in-list (cdr (series-pagetree)))])
(define series-metas (get-metas series-pagenode))
(make-cache:series
#:page series-pagenode
#:title (hash-ref series-metas 'title)
#:published (hash-ref series-metas 'published "")
#:noun-plural (hash-ref series-metas 'noun-plural "")
#:noun-singular (hash-ref series-metas 'noun-singular ""))))
(void (apply insert! (cache-conn) series-rows)))
