Index: blog.rkt ================================================================== --- blog.rkt +++ blog.rkt @@ -4,11 +4,11 @@ ; This file is licensed under the Blue Oak Model License 1.0.0. ;; Builds the paginated “blog” HTML files (blog-pg1.html ...) from the SQLite cache ;; The files will be written out every time this module is evaluated! (see end) -(require "crystalize.rkt" +(require "cache.rkt" "snippets-html.rkt" "dust.rkt" racket/file sugar/list) ADDED cache.rkt Index: cache.rkt ================================================================== --- cache.rkt +++ cache.rkt @@ -0,0 +1,203 @@ +#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 + "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) + delete-article! + delete-notes! + current-plain-title + articles + articles+notes + listing-htmls + + + + 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] + [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 + ([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))) + +;; +;; ~~~ 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])) + +;; (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 (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 + a.conceal) + (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 (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 + A.conceal) + (union + (~> (from cache:note #:as N) + (select (fragment (ast:as (ast:qualified "N" html-field) "html")) + N.published + 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` + +;; 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 "")) Index: crystalize.rkt ================================================================== --- crystalize.rkt +++ crystalize.rkt @@ -1,125 +1,28 @@ #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 +(require deta + db/base + db/sqlite3 + threading + racket/match racket/string - pollen/pagetree + txexpr 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 - - - - 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] - [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 - ([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))) - +) + +(require "dust.rkt" "cache.rkt" "snippets-html.rkt") + +(provide parse-and-cache-article! + cache-series!) ;; 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))) @@ -327,99 +230,10 @@ (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])) - -;; (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 (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 - a.conceal) - (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 (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 - A.conceal) - (union - (~> (from cache:note #:as N) - (select (fragment (ast:as (ast:qualified "N" html-field) "html")) - N.published - 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` - -;; 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 (cache-series!) (define here-page (path->string (here-output-path))) Index: keyword-index.rkt ================================================================== --- keyword-index.rkt +++ keyword-index.rkt @@ -12,11 +12,11 @@ racket/string db/base net/uri-codec pollen/template) -(require "crystalize.rkt" +(require "cache.rkt" "dust.rkt" "snippets-html.rkt") (provide main) Index: makefile ================================================================== --- makefile +++ makefile @@ -5,11 +5,11 @@ # ~~~ Variables used by rules ~~~ # core-files := pollen.rkt dust.rkt -html-deps := snippets-html.rkt tags-html.rkt crystalize.rkt +html-deps := snippets-html.rkt tags-html.rkt crystalize.rkt cache.rkt article-sources := $(wildcard articles/*.poly.pm) articles-html := $(patsubst %.poly.pm, %.html, $(article-sources)) articles-pdf := $(patsubst %.poly.pm, %.pdf, $(article-sources)) Index: pollen.rkt ================================================================== --- pollen.rkt +++ pollen.rkt @@ -11,16 +11,17 @@ pollen/setup)) (require pollen/tag pollen/setup racket/function + "cache.rkt" "tags-html.rkt" "snippets-html.rkt" "crystalize.rkt") (provide (all-defined-out) - (all-from-out "crystalize.rkt" "snippets-html.rkt")) + (all-from-out "crystalize.rkt" "snippets-html.rkt" "cache.rkt")) (module setup racket/base (require syntax/modresolve racket/runtime-path pollen/setup) @@ -30,15 +31,17 @@ (define-runtime-path tags-html.rkt "tags-html.rkt") (define-runtime-path snippets-html.rkt "snippets-html.rkt") (define-runtime-path dust.rkt "dust.rkt") (define-runtime-path crystalize.rkt "crystalize.rkt") + (define-runtime-path cache.rkt "cache.rkt") (define cache-watchlist (map resolve-module-path (list tags-html.rkt snippets-html.rkt dust.rkt + cache.rkt crystalize.rkt)))) (case (current-poly-target) [(html) (init-cache-db!)]) Index: rss-feed.rkt ================================================================== --- rss-feed.rkt +++ rss-feed.rkt @@ -10,11 +10,11 @@ racket/file racket/date racket/string db/base "dust.rkt" - "crystalize.rkt") + "cache.rkt") (provide main) (define feed-author default-authorname) (define feed-author-email "joel@jdueck.net")