@@ -1,242 +1,168 @@ #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 +(require deta db/base db/sqlite3 threading txexpr gregor) + +(require racket/match + racket/string + pollen/pagetree 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)) + (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! + 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 + + + + unfence) + +;; Cache DB and Schemas + +(define DBFILE (build-path (current-project-root) "vitreous2.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 date/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 (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 (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)] - [series-node (series-pagenode)] [header (html$-article-open pagenode title-specified? title-tx pubdate)] - [footertext (make-article-footertext pagenode series-node disposition disp-note-id (length note-txprs))] + [series-node (metas-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)]) - - (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 - (html$-article-listing-short pagenode pubdate title-html))) - - (apply query! (make-insert/replace-query 'articles table_articles-fields) article-record) - + [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))) -;; ~~~ 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 "
    " - ,@(list/articles "listing_short_html" #:series s #:limit limit order) - "
")) - -(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 "" 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 '()])) +(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)))] @@ -249,22 +175,21 @@ [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 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’." - s-noun - series - s-title)] - [else ""])) + (match (series-metas-title) + [(? non-empty-string? s-title) + (format "This is ~a, part of ‘~a’." + (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." pagenode @@ -282,91 +207,74 @@ [else ""])) (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 -;; -(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)] +(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 (crystalize-note! note-tx pagenode parent-title-plain) +(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) - (and ((length (string-split disposition-attr)) . >= . 2))) + (>= (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)) + (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))) -(define (article-plain-title pagenode) - (query-value (sqltools:dbc) "SELECT `title_plain` FROM `articles` WHERE `pagenode` = ?1" (symbol->string pagenode))) - ;; ~~~ 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" "") @@ -375,55 +283,123 @@ (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 (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?)) - +(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! "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)) + (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 (["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.: ( articles+notes) +(define ( query-func #:series [s #t] #:limit [lim -1] #:order [ord 'desc]) + `(style ,@(listing-htmls (query-func 'full #:series s #:limit lim #:order ord)))) +;; ^^^^^ + +(define ( query-func #:series [s #t] #:limit [lim -1] #:order [ord 'desc]) + `(style ,@(listing-htmls (query-func 'excerpt #:series s #:limit lim #:order ord)))) +;; ^^^^^^^^ + +(define ( query-func #:series [s #t] #:limit [lim -1] #:order [ord 'desc]) + `(style "
    " + ,@(listing-htmls (query-func 'short #:series s #:limit lim #:order ord)) + "
")) ;; ^^^^^^ + +;; Remove "" 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 (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)) +(define (cache-series!) + (query-exec cache-conn + (delete (~> (from cache:series #:as s) + (where (= s.page ,(here-output-path)))))) + (insert-one! cache-conn + (make-cache:series + #:page (here-output-path) + #: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 ""))))