Index: blog.rkt ================================================================== --- blog.rkt +++ blog.rkt @@ -36,17 +36,15 @@ ◊html$-page-body-close[] }) ;; Grabs all the articles+notes from the cache and writes out all the blog page files (define (build-blog) - (spell-of-summoning!) ; Turn on the DB - - (define articles+notes (slice-at (list/articles+notes 'listing_full_html #:series #f) per-page)) - (define pagecount (length articles+notes)) + (define arts-n-notes (slice-at (listing-htmls (articles+notes 'full #:series #f)) per-page)) + (define pagecount (length arts-n-notes)) (for ([pagenum (in-range 1 (+ 1 pagecount))] - [page (in-list articles+notes)]) + [page (in-list arts-n-notes)]) (define filename (format "blog-pg~a.html" pagenum)) (displayln (format "Writing: ~a" filename)) (display-to-file (blog-page (apply string-append page) pagenum pagecount) filename #:mode 'text Index: code-docs/crystalize.scrbl ================================================================== --- code-docs/crystalize.scrbl +++ code-docs/crystalize.scrbl @@ -9,10 +9,11 @@ "../dust.rkt" "../crystalize.rkt" racket/base racket/contract racket/string + deta txexpr pollen/template pollen/pagetree sugar/coerce)) @@ -20,86 +21,61 @@ @defmodule["crystalize.rkt" #:packages ()] “Crystalizing” is an extra layer in between docs and templates that destructures the doc and stores it in various pieces in a SQLite cache. Individual articles save chunks of rendered HTML to the -cache when their individual pages are rendered. The SQLite cache is then referenced by any page that -collects multiple articles and notes together. This is much faster than fetching docs and metas -through Pollen’s cache and re-converting them to HTML. - -@defproc[(spell-of-summoning!) void?] - -Initializes the SQLite database cache file. This involves creating the file -(@filepath{vitreous.sqlite}) if it does not exist, and running queries to create tables in the -database if they do not exist. +cache when their individual pages are rendered. When pulling together listings of articles in +different contexts that need to be filtered and sorted, a SQL query is much faster than trolling +through the Pollen cache for matching docs and regenerating the HTML. + +@defproc[(init-cache-db!) void?] + +Initializes the SQLite database cache file (named @filepath{vitreous.sqlite} and located in the +project root folder) by running queries to create tables in the database if they do not exist. (The +file itself is created at the module level.) This function is called automatically in @filepath{pollen.rkt} whenever HTML is the target output. -@defproc[(crystalize-article! [pagenode pagenode?] [doc txexpr?]) non-empty-string?] +@defproc[(parse-and-cache-article! [pagenode pagenode?] [doc txexpr?]) non-empty-string?] Returns a string containing the HTML of @racket[_doc]. @margin-note{This is one function that breaks -my convention of using a prefix of @tt{html$-} for functions that return strings of HTML.} -Privately, it does a lot of other work. The article is saved to the SQLite cache. If the article -specifies a @racket['series] meta, information about that series is fetched and used in the -rendering of the article. If there are @racket[note]s in the doc, they are parsed and saved -individually to the SQLite cache. If any of the notes use the @code{#:disposition} attribute, -information about the disposition is parsed out and used in the rendering of the article. - -@defproc[(crystalize-series!) void?] - -Saves metas for the current series page in the SQLite cache. Meant to be called from the HTML -template for “Series” pages (Pollen documents located in @racket[series-folder]). - -@defproc[(crystalize-index-entries! [pagenode pagenode?] [doc txexpr?]) void?] - -Saves any @racket[index] enries entries in @racket[_doc] to the SQLite cache. - -@margin-note{This function was originally private; I provided it out only so it could be called -manually from @tt{index.html.pp}.} - -@deftogether[(@defproc[(list/articles [type (or/c 'listing_full_html - 'listing_short_html - 'listing_excerpt_html)] - [#:series series (or/c string? boolean?) #t] - [#:limit limit stringish? -1] - [order string? "DESC"]) (listof string?)] - @defproc[(list/articles+notes [type (or/c 'listing_full_html - 'listing_short_html - 'listing_excerpt_html)] - [#:series series (or/c string? boolean?) #t] - [#:limit limit stringish? -1] - [order string? "DESC"]) (listof string?)])] - -Fetches the HTML for all articles from the SQLite cache and returns a list of strings containing the -HTML for each. The articles will be ordered by publish date according to @racket[_order] and -optionally limited to the series specified in @racket[_series]. - -If @racket[_series] expression evaluates to @racket[#f], articles will not be filtered by series. If -it evaluates to @racket[#t] (the default), articles will be filtered by those that specify the -current output of @racket[here-output-path] in their @tt{series_pagenode} column in the SQLite -cache. If a string is supplied, articles will be filtered by those containing that exact value in -their @tt{series_pagenode} column in the SQLite cache. - -The @racket[_order] expression must evaluate to either @racket["ASC"] or @racket["DESC"] and the -@racket[_limit] expressions must evaluate to a value suitable for use in the @tt{LIMIT} clause of -@ext-link["https://sqlite.org/lang_select.html"]{a SQLite @tt{SELECT} statement}. An expression that -evaluates to a negative integer (the default) is the same as having no limit. - -@deftogether[(@defproc[(listing<>-short/articles [#:series series (or/c string? boolean?) #t] - [#:limit limit stringish? -1] - [order string? "DESC"]) txexpr?] - @defproc[(listing<>-full/articles [#:series series (or/c string? boolean?) #t] - [#:limit limit stringish? -1] - [order string? "DESC"]) txexpr?])] - -@margin-note{Notice how the functions that start with @tt{list/} return lists and the functions that -start with @tt{listing<>} return fenced HTML strings. Maybe this is ugly, but it helps me keep these -otherwise too-similar sets of functions straight in my head.} - -Fetches the HTML for all articles from the SQLite cache and returns the HTML strings fenced inside -a @racket['style] tagged X-expression. The articles will be ordered by publish date according to +my convention of using a prefix of @tt{html$-} for functions that return a single string of HTML.} + +Privately, it does a lot of other work. The article is analyzed, additional metadata is constructed, +and it is saved to the SQLite cache. If the article specifies a @racket['series] meta, information +about that series is fetched and used in the rendering of the article. If there are @racket[note]s +in the doc, they are parsed and saved individually to the SQLite cache. If any of the notes use the +@code{#:disposition} attribute, information about the disposition is parsed out and used in the +rendering of the article. + +@deftogether[(@defproc[( + [query-func (-> any/c query?)] + [#:series series (or/c string? (listof string? boolean?)) #t] + [#:limit limit integer? -1] + [order stringish? 'desc]) txexpr?] + @defproc[( + [query-func (-> any/c query?)] + [#:series series (or/c string? (listof string? boolean?)) #t] + [#:limit limit integer? -1] + [order stringish? 'desc]) txexpr?] + @defproc[( + [query-func (-> any/c query?)] + [#:series series (or/c string? (listof string? boolean?)) #t] + [#:limit limit integer? -1] + [order stringish? 'desc]) txexpr?])] + +Fetches the HTML for items from the SQLite cache and returns the HTML strings fenced inside +a @racket['style] tagged X-expression. The items will be ordered by publish date according to @racket[_order] and optionally limited to the series specified in @racket[_series]. + +The @racket[_query-func] should be either @racket[articles], which will create a listing of articles +only, or @racket[articles+notes], which will include notes intermingled with articles. + +@margin-note{Note that the signature shown for the @racket[_query-func] argument above is +incomplete. If you choose to pass a function other than @racket[articles] or +@racket[articles+notes], you must use a function with exactly the same signature as those +functions.} If @racket[_series] expression evaluates to @racket[#f], articles will not be filtered by series. If it evaluates to @racket[#t] (the default), articles will be filtered by those that specify the current output of @racket[here-output-path] in their @tt{series_pagenode} column in the SQLite cache. If a string is supplied, articles will be filtered by those containing that exact value in @@ -114,29 +90,38 @@ escaped by @racket[->html] in the template. This tag was picked for the job because there will generally never be a need to include any actual CSS information inside a @tt{"] removed. The contents of the style tags are left intact. -Use this with strings returned from @racket[->html] when called on docs containing -@racket[listing<>-full/articles] or its siblings. - -@defproc[(article-plain-title [pagenode pagenode?]) non-empty-string?] - -Fetches the “plain” title (i.e., with no HTML markup) for the given article from the SQLite cache. -If the article did not specify a title, a default title is supplied. If the article contained -a @racket[note] that used the @code{#:disposition} attribute, the disposition-mark may be included -in the title. - -Note that this needs to be called @emph{after} @racket[crystalize-article!] in order to get an +Use this with strings returned from @racket[->html] when called on docs that use the +@racket[] tag function or its siblings. + +@defparam[current-plain-title non-empty-string? #:value "void"] + +Contains (or sets) the “plain” title (i.e., with no HTML markup) for the current article based on +analysis done by @racket[parse-and-cache-article!]. If the article did not specify a title, +a default title is supplied. If the article contained a @racket[note] that used the +@code{#:disposition} attribute, the disposition-mark may be included in the title. + +Note that this needs to be called @emph{after} @racket[parse-and-cache-article!] in order to get an up-to-date value. Index: code-docs/dust.scrbl ================================================================== --- code-docs/dust.scrbl +++ code-docs/dust.scrbl @@ -159,21 +159,21 @@ "individual as Queequeg circulating among the polite society of a civilized " "town, that astonishment soon departed upon taking my first daylight " "stroll through the streets of New Bedford…"))) (default-title (get-elements doc))] -@defproc[(series-pagenode) pagenode?] +@defproc[(metas-series-pagenode) pagenode?] If @code{(current-metas)} has the key @racket['series], converts its value to the pagenode pointing to that series, otherwise returns @racket['||]. -@defproc[(series-noun) string?] +@defproc[(series-metas-noun) string?] If @code{(current-metas)} has the key @racket['series], and if the corresponding series defines a meta value for @racket['noun-singular], then return it, otherwise return @racket[""]. -@defproc[(series-title) string?] +@defproc[(series-metas-title) string?] If @code{(current-metas)} has the key @racket['series], and if the corresponding series defines a meta value for @racket['title], then return it, otherwise return @racket[""]. @defproc[(invalidate-series) (or/c void? boolean?)] Index: code-docs/main.scrbl ================================================================== --- code-docs/main.scrbl +++ code-docs/main.scrbl @@ -28,9 +28,8 @@ @local-table-of-contents[] @include-section["overview.scrbl"] @include-section["pollen.scrbl"] @; pollen.rkt @include-section["dust.scrbl"] @; dust.rkt -@include-section["sqlite-tools.scrbl"] @; sqlite-tools.rkt @include-section["snippets-html.scrbl"] @; you get the idea @include-section["crystalize.scrbl"] DELETED code-docs/sqlite-tools.scrbl Index: code-docs/sqlite-tools.scrbl ================================================================== --- code-docs/sqlite-tools.scrbl +++ code-docs/sqlite-tools.scrbl @@ -1,200 +0,0 @@ -#lang scribble/manual - -@; SPDX-License-Identifier: BlueOak-1.0.0 -@; This file is licensed under the Blue Oak Model License 1.0.0. - -@(require "scribble-helpers.rkt" - scribble/example) - -@(require (for-label "../pollen.rkt" - "../sqlite-tools.rkt" - racket/base - racket/contract - db - sugar/coerce)) - -@(define my-eval (make-base-eval)) -@(my-eval '(require "sqlite-tools.rkt")) - -@title{@filepath{sqlite-tools.rkt}} - -@defmodule["sqlite-tools.rkt" #:packages ()] - -Provides a very light set of utility functions for managing a single SQLite database. These -functions are completely agnostic as to the database schema. - -It is important to note, these functions are @bold{not safe} for use with data provided by untrusted -users! In many places they use @racket[format] to blindly insert table and field names, which is -dangerous (see @secref["dbsec-sql-injection" #:doc '(lib "db/scribblings/db.scrbl")]). It’s fine for -this project, since its only use of a database is as a disposable cache that can be safely deleted -and regenerated at any time, and there are no users except me. - -@section{Parameters} - -@defparam[sqltools:dbc con connection? #:value "No DB connection!"] - -The current database connection. This module assumes a single active connection and stores it in -this parameter so you don’t have to pass it to a function every time you execute a query. It’s -provided here so you can use it directly with the functions provided by @racketmodname[db] (all of -which are re-provided by this module for convenience). - -@defboolparam[sqltools:log-queries? v #:value #f] - -A kill-switch that determines whether @racket[log-query] does anything. - -@section{SQL building-blocks} - -@defproc[(log-query [str string?]) void?] - -Prints @racket[_str] to standard output with @racket[println], but only if -@racket[(sqltools:log-queries?)] is not @code{#f}. - -This is called by every function in this module that actually executes database queries (i.e., those -whose names end in @tt{!}), so if you need to you can see what’s actually being sent to the -database. - -@defproc[(backtick [str stringish?]) string?] - -Returns @racket[_str] surrounded by backticks. - -@examples[#:eval my-eval -(backtick "field")] - -@defproc[(list->sql-fields [lst (listof stringish?)]) string?] - -Given a list of values, returns a single string containing the list elements in order, surrounded -by backticks and separated by commas. - -@examples[#:eval my-eval -(list->sql-fields '("id" "name" "address")) -(list->sql-fields '(or use symbols))] - -@defproc[(list->sql-values [lst (listof any/c)]) string?] - -Given a list of values, return a string containing those values separated by commas inside a pair of -parentheses. Any string values in the list will be surrounded by quote marks. - -@examples[#:eval my-eval -(list->sql-values '(0 "hello" NULL 34))] - -@defproc[(list->sql-parameters [lst (listof stringish?)]) string?] - -Given a list of values, return a single string with numbered parameter placeholders, suitable for -use in a parameterized SQL query. - -@examples[#:eval my-eval -(list->sql-parameters '(name rank serial))] - -@deftogether[(@defproc[(bool->int [b any/c]) exact-integer?] - @defproc[(int->bool [i exact-integer?]) boolean?])] - -SQLite has no “boolean” column type (in fact SQLite has no column types, period), so boolean values -must be converted to/from the values @code{1} or @code{0}. When converting @emph{from} boolean, -@code{#f} becomes @code{0} and any other value becomes @code{1}. When converting integers @emph{to} -boolean, @code{0} becomes @code{#f} and any other value becomes @code{#t}. - -@examples[#:eval my-eval -(bool->int #t) -(bool->int "") -(bool->int #f) -(int->bool 1) -(int->bool -100) -(int->bool 0)] - -@defproc[(vector->hash [vec vector?] [fields (listof symbolish?)]) hash?] - -Returns a hash table which uses the values in @racket[_fields] as keys and the vector elements as -the values. If @racket[_vec] and @racket[_fields] do not have the same number of elements, the -returned hash will have only as many key/value pairs as the one with the fewest elements. - -The functions in Racket’s @racketmodname[db] module return query results as @seclink["vectors" #:doc -'(lib "scribblings/reference/reference.scrbl")]{vectors}, but it is much easier to make use of them -as hash tables, with the field names as keys. - -@examples[#:eval my-eval -(vector->hash '#("Yossarian" "Cpt" "Z-247") '(name rank serial)) - -(code:comment @#,elem{When v and fields are unequal in length:}) -(vector->hash '#("a" "b" "c") '(1 2)) -(vector->hash '#("a" "b") '(1 2 3))] - -@section{Tools for making query strings} - -These functions don’t actually do anything to the database. They just convert lists into various -kinds of SQL query strings. This way you can use lists to define what you want from the database -instead of writing out the queries by hand. - -Again, these functions use @racket[format] to build query strings, so they aren’t safe to use with -user-supplied data; see the warning at the top of this document. - -@defproc[(make-table-schema [tablename string?] - [fields (listof stringish?)] - [#:primary-key-cols pk-cols (listof stringish?) '()]) - string?] - -Given a table name and a list of fields, returns a string containing the SQLite-flavored query that -will create that table with those fields. If @racket[_pk-cols] is empty, the first value in -@racket[_fields] is designated in the query as the primary key. - -@examples[#:eval my-eval -(make-table-schema "vals" '(a b c)) -(make-table-schema "vals" '(a b c) #:primary-key-cols '(a b))] - -@defproc[(make-insert/replace-query [table stringish?] [fields (listof stringish?)]) string?] - -Returns a SQLite-flavored query for inserting/updating a record. The list of values to insert is -parameterized so it can be used in conjunction with a @racket[list] of values. - -@examples[#:eval my-eval -(make-insert/replace-query 'vals '(a b c))] - -This query relies on the fact that in SQLite every table contains a @tt{rowid} column by default. -For more information on why/how the query works, see -@ext-link["https://sqlite.org/lang_insert.html"]{the SQLite docs for @tt{INSERT}}. - -@defproc[(make-insert-rows-query [table stringish?] [fields (listof stringish?)] [rows (listof -(listof any/c))]) string?] - -Returns a SQLite query string for inserting multiple rows. - -@examples[#:eval my-eval -(make-insert-rows-query 'people '(id name) '((1 "Alice") (2 "Bob")))] - -@defproc[(make-select-query [table stringish?] [fields (listof stringish?)] [#:where where-clause -stringish?]) string?] - -Returns a SQLite query string for selecting rows from the database. - -@examples[#:eval my-eval -(make-select-query 'vals '(a b c) #:where 1)] - -@section{Query functions} - -These functions actually execute queries on the currently active database connection stored in the -@racket[sqltools:dbc] parameter. - -@defproc[(init-db! [filename (or/c path-string? 'memory 'temporary)] [query statement?] ...) void?] - -Initialize the database connection using @racket[sqlite3-connect] with @racket['create] mode. The -filename may be followed by any number of queries which will immediately be executed on the -database; this can be useful for initializing tables and other setup tasks. - -The database connection will be stored in the @racket[sqltools:dbc] parameter. If that parameter -already holds an active connection, it will be @racket[disconnect]ed and then replaced with the new -connection. - -@defproc[(query! [query-statement statement?] [parameters any/c] ...) void?] - -Executes a SQL statement using the current connection. - -@defproc*[([(select-rows! [query statement?] [fieldnames (listof stringish?)]) (listof hash?)] - [(select-rows! [table stringish?] [fieldnames (listof stringish?)] [where-clause - stringish?]) (listof hash?)])] - -Execute a SQL query that returns rows from the database, either using a raw query (first form -above), or using a table name, field names, and a @racket[_where-clause] (second form above). -Returns a list of hashes whose keys are the values supplied in @racket[_fieldnames]. - -In the first form, @racket[_fieldnames] should list @emph{in order} all the fields that will be -returned by the query. If this isn’t done, the keys for each row’s hash will likely point to values -for the wrong fields. Index: crystalize.rkt ================================================================== --- crystalize.rkt +++ crystalize.rkt @@ -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 "")))) Index: dust.rkt ================================================================== --- dust.rkt +++ dust.rkt @@ -19,13 +19,13 @@ (provide maybe-meta ; Select from (current-metas) or default value ("") if not available maybe-attr ; Return an attribute’s value or a default ("") if not available here-output-path here-id - series-noun ; Retrieve noun-singular from current 'series meta, or "" - series-title ; Retrieve title of series in current 'series meta, or "" - series-pagenode + series-metas-noun ; Retrieve noun-singular from current 'series meta, or "" + series-metas-title ; Retrieve title of series in current 'series meta, or "" + metas-series-pagenode invalidate-series make-tag-predicate tx-strs ymd->english ymd->dateformat @@ -67,25 +67,25 @@ (->output-path (apply build-path rel-path-parts))] [else (string->path ".")])) ;; Checks current-metas for a 'series meta and returns the pagenode of that series, ;; or '|| if no series is specified. -(define (series-pagenode) +(define (metas-series-pagenode) (define maybe-series (or (select-from-metas 'series (current-metas)) "")) (cond [(non-empty-string? maybe-series) (->pagenode (format "~a/~a.html" series-folder maybe-series))] [else '||])) -(define (series-noun) - (define series-pnode (series-pagenode)) +(define (series-metas-noun) + (define series-pnode (metas-series-pagenode)) (case series-pnode ['|| ""] ; no series specified [else (or (select-from-metas 'noun-singular series-pnode) "")])) -(define (series-title) - (define series-pnode (series-pagenode)) +(define (series-metas-title) + (define series-pnode (metas-series-pagenode)) (case series-pnode ['|| ""] ; no series specified [else (or (select-from-metas 'title series-pnode) "")])) ;; Generates a short ID for the current article Index: index.html.pp ================================================================== --- index.html.pp +++ index.html.pp @@ -4,12 +4,12 @@ ◊; This file is licensed under the Blue Oak Model License 1.0.0. ◊(require pollen/template db/base racket/list racket/match) ◊(define (fetch-series) - (define q "SELECT noun_plural, pagenode, title FROM series ORDER BY noun_plural DESC") - (query-rows (sqltools:dbc) q)) + (define q "SELECT noun_plural, page, title FROM series ORDER BY noun_plural DESC") + (query-rows cache-conn q)) ◊(define (series-item->txpr s) (match-define (list n pagenode title) s) `(li (a [[href ,pagenode]] (i ,title)))) Index: keyword-index.rkt ================================================================== --- keyword-index.rkt +++ keyword-index.rkt @@ -102,15 +102,15 @@ ;; Get the index entries from the SQLite cache, return them as a list of vectors (Records!) (define (fetch-entries) (define q ◊string-append{ - SELECT entry, subentry, a.rowid, "◊web-root" || k.pagenode || "#" || anchor AS href, title_plain - FROM keywordindex k INNER JOIN articles a - ON a.pagenode = k.pagenode + SELECT entry, subentry, a.rowid, "◊web-root" || k.page || "#" || html_anchor AS href, title_plain + FROM index_entries k INNER JOIN articles a + ON a.page = k.page ORDER BY entry COLLATE NOCASE ASC, subentry COLLATE NOCASE ASC;}) - (query-rows (sqltools:dbc) q)) + (query-rows cache-conn q)) ;; Convert a list of vectors from the cache DB into a list of the form: ;; ((FIRST-LETTER (entries ...)) ...) ;; The method relies on the records being pre-sorted by the SQL query. (define (group-entries records) @@ -158,11 +158,10 @@ ◊html$-page-body-close[] }) (define (main) - (spell-of-summoning!) ; Turn on DB (displayln "Writing keyword-index.html…") (display-to-file (html$-keywordindex-page (html$-index (group-entries (fetch-entries)))) "keyword-index.html" #:mode 'text #:exists 'replace)) Index: pollen.rkt ================================================================== --- pollen.rkt +++ pollen.rkt @@ -38,11 +38,11 @@ snippets-html.rkt dust.rkt crystalize.rkt)))) (case (current-poly-target) - [(html) (spell-of-summoning!)]) + [(html) (init-cache-db!)]) ;; Macro for defining tag functions that automatically branch based on the ;; current output format and the list of poly-targets in the setup module. ;; Use this macro when you know you will need keyword arguments. ;; Index: rss-feed.rkt ================================================================== --- rss-feed.rkt +++ rss-feed.rkt @@ -45,30 +45,30 @@ ;; Get the data out of the SQLite cache as vectors (define (fetch-rows) (define fields '(pagenode title_plain published updated author doc_html)) (define select #<<--- - SELECT `path`, `title`, `published`, `updated`, `author`, `entry-contents` FROM - (SELECT `pagenode` AS `path`, + SELECT `path`, `title`, `published`, `updated`, `author`, `entry_contents` FROM + (SELECT `page` AS `path`, `title_plain` AS `title`, `published`, `updated`, `author`, - `doc_html` AS `entry-contents` + `doc_html` AS `entry_contents` FROM `articles` UNION - SELECT `pagenode` || '#' || `note_id` AS `path`, + SELECT `page` || '#' || `html_anchor` AS `path`, `title_plain` AS `title`, - `date` AS `published`, + `published`, "" AS `updated`, `author`, - `content_html` as `entry-contents` + `content_html` as `entry_contents` FROM `notes`) ORDER BY `published` DESC LIMIT ~a --- ) - (query-rows (sqltools:dbc) (format select feed-item-limit))) + (query-rows cache-conn (format select feed-item-limit))) (define (vector->rss-item vec) (match-define (vector path title published updated author contents) vec) (define entry-url (string-append feed-site-url web-root path)) @@ -99,7 +99,6 @@ ,@(map vector->rss-item (fetch-rows)))) (string-append "\n" (xexpr->string feed-xpr))) (define (main) - (spell-of-summoning!) ; Turn on the cache DB connection (display-to-file (rss-feed) "feed.xml" #:mode 'text #:exists 'replace)) Index: series/template.html.p ================================================================== --- series/template.html.p +++ series/template.html.p @@ -1,8 +1,8 @@ -◊crystalize-series! +◊cache-series![] ◊html$-page-head[(select-from-metas 'title metas)] ◊html$-page-body-open["series-page"] ◊(unfence (->html doc #:splice? #t)) Index: snippets-html.rkt ================================================================== --- snippets-html.rkt +++ snippets-html.rkt @@ -113,11 +113,11 @@ [else ""])) ◊string-append{

◊|title-html-flow|

-

+

◊|contents|
◊author-part DELETED sqlite-tools.rkt Index: sqlite-tools.rkt ================================================================== --- sqlite-tools.rkt +++ sqlite-tools.rkt @@ -1,258 +0,0 @@ -#lang racket/base - -; SPDX-License-Identifier: BlueOak-1.0.0 -; This file is licensed under the Blue Oak Model License 1.0.0. - -;; Provides a very light set of utility functions for a SQLite database. -;; These functions are completely agnostic as to the database schema. -;; These functions are NOT SAFE for use with data provided by untrusted users! - -(require db/sqlite3 - db/base - racket/list - racket/match - racket/function - racket/contract - sugar/coerce) - -(module+ test - (require rackunit)) - -(provide sqltools:dbc - sqltools:log-queries?) - -(provide - (contract-out - ;; Utility functions - [log-query (string? . -> . void?)] - [vector->hash (vector? (listof symbolish?) . -> . hash?)] - [backtick (stringish? . -> . string?)] - [list->sql-fields ((listof stringish?) . -> . string?)] - [list->sql-values ((listof stringish?) . -> . string?)] - [list->sql-parameters ((listof any/c) . -> . string?)] - [bool->int (any/c . -> . exact-integer?)] - [int->bool (exact-integer? . -> . boolean?)] - - ;; Simple SQL makers - [make-table-schema ((string? (listof stringish?)) - (#:primary-key-cols (listof stringish?)) - . ->* . string?)] - [make-insert/replace-query (stringish? (listof stringish?) . -> . string?)] - [make-insert-rows-query (stringish? (listof stringish?) (listof (listof stringish?)) . -> . string?)] - [make-select-query (stringish? (listof stringish?) #:where stringish? . -> . string?)] - - ;; Database operations - [init-db! ((pathish?) () #:rest (listof string?) . ->* . void?)] - [query! ((string?) () #:rest (listof any/c) . ->* . void?)] - [select-rows! (case-> - (stringish? (listof stringish?) any/c . -> . (or/c empty? hash?)) - (string? (listof stringish?) . -> . (or/c empty? hash?)))])) - -;; ~~~ Private use ~~~ - -(define uninitialized-connection "No DB connection!") -(define (weave xs ys) - (for/fold [(woven null) - #:result (reverse woven)] - ([x (in-list xs)] - [y (in-list ys)]) - (cons y (cons x woven)))) - -(define (sql-val v) - (cond [(string? v) (string-append "\"" v "\"")] - [else (format "~a" v)])) - -;; ~~~ Provided parameters ~~~ - -(define sqltools:dbc (make-parameter uninitialized-connection)) -(define sqltools:log-queries? (make-parameter #f)) - -;; ~~~ Provided utility functions ~~~ - -(define (backtick str) (format "`~a`" str)) -(define (list->sql-fields fields) (apply string-append (add-between (map backtick fields) ", "))) -(define (list->sql-values vals) - (string-append "(" (apply string-append (add-between (map sql-val vals) ", ")) ")")) -(define (list->sql-parameters fields) - (apply string-append (add-between (map (λ(x) (format "?~a" (add1 x))) (range (length fields))) ", "))) - -;; For storing/reading boolean values (SQLite uses integers) -(define (bool->int b?) - (cond [b? 1] [else 0])) - -(define (int->bool i) - (not (= i 0))) - -;; TESTING: utility functions… -(module+ test - (check-equal? (backtick "field") "`field`") - (check-equal? (list->sql-fields '("f1" "f2" "f3")) "`f1`, `f2`, `f3`") - (check-equal? (list->sql-fields '(f1 f2 f3)) "`f1`, `f2`, `f3`") ; Can use symbols too - (check-equal? (list->sql-parameters '("name" "rank" "serial")) "?1, ?2, ?3") - (check-equal? (list->sql-parameters '(name rank serial)) "?1, ?2, ?3") - (check-equal? (list->sql-values '(100 "hello" 3)) "(100, \"hello\", 3)") - (check-equal? (weave '(x y z) '(1 2 3)) '(x 1 y 2 z 3)) - - (check-equal? (bool->int #f) 0) - (check-equal? (bool->int #t) 1) - (check-equal? (bool->int "xblargh") 1) - (check-equal? (int->bool 0) #f) - (check-equal? (int->bool 1) #t) - (check-equal? (int->bool -1) #t) - (check-equal? (int->bool 37) #t) - (check-exn exn:fail? (lambda () (int->bool "x")))) - -;; ~~~ Public functions ~~~ - -;; Prints to stdout if logging is on -(define (log-query q) (unless (not (sqltools:log-queries?)) (println q))) - -;; Using a list of field names, convert a vector into a hash that uses the -;; field names (in symbol form) for keys. -;; Racket’s db functions all return vectors; hashes are much easier to use. -;; If fields and v are not equal in length, the unpairable elements are omitted -;; from the hash! -(define (vector->hash v fields) - (cond [(zero? (vector-length v)) null] - [else (let ([keys (map ->symbol fields)] - [vals (vector->list v)]) - (apply hash (weave keys vals)))])) - -;; TESTING: vector->hash... -(module+ test - (let ([test-row '#("Joe" "PFC" 123)] - [test-cols-SYMBOL '(name rank serial)] - [test-cols-STRING '("name" "rank" "serial")] - [desired-result '#hash((serial . 123) (rank . "PFC") (name . "Joe"))]) - (check-equal? (vector->hash test-row test-cols-SYMBOL) desired-result) - (check-equal? (vector->hash test-row test-cols-STRING) desired-result)) - - ;; Behavior when v and fields are unequal in length: - (check-equal? (vector->hash '#("foo" "bar") '(a b c)) - '#hash((a . "foo") (b . "bar"))) - (check-equal? (vector->hash '#("foo" "bar" "baz") '(a b)) - '#hash((a . "foo") (b . "bar")))) - -;; Create a simple table schema from a list of fields, optionally specifying -;; primary key -(define (make-table-schema tablename fields #:primary-key-cols [primary-cols '()]) - (define primary-key - (format "PRIMARY KEY (~a)" - (list->sql-fields (if (empty? primary-cols) (list (first fields)) primary-cols)))) - (format "CREATE TABLE IF NOT EXISTS `~a` (~a, ~a);" - tablename - (list->sql-fields fields) - primary-key)) - -;; Create a query that inserts a row if it doesn’t exist (based on the first -;; column only), or updates it if it does. The returned query is parameterized, -;; and must be used with a list of values equal in length to the number of -;; fields given. -(define (make-insert/replace-query tablename fields) - (format "INSERT OR REPLACE INTO `~a` (`rowid`, ~a) VALUES ((SELECT `rowid` FROM `~a` WHERE `~a`= ?1), ~a)" - tablename - (list->sql-fields fields) - tablename - (first fields) - (list->sql-parameters fields))) - -;; Create a query that inserts multiple rows. -(define (make-insert-rows-query tablename fields rows) - (define row-values - (apply string-append (add-between (map list->sql-values rows) ", "))) - (format "INSERT INTO `~a` (~a) VALUES ~a;" tablename (list->sql-fields fields) row-values)) - -;; Simple row selection -(define (make-select-query table fields #:where where-clause) - (format "SELECT ~a FROM `~a` WHERE ~a" - (list->sql-fields fields) - table - where-clause)) - -;; TESTING: SQL query makers... -(module+ test - (check-equal? (make-table-schema 'posts '(title date)) - "CREATE TABLE IF NOT EXISTS `posts` (`title`, `date`, PRIMARY KEY (`title`));") - (check-equal? (make-table-schema "posts" '("title" "date")) - "CREATE TABLE IF NOT EXISTS `posts` (`title`, `date`, PRIMARY KEY (`title`));") - (check-equal? (make-table-schema 'posts '(title date) #:primary-key-cols '(author date)) - "CREATE TABLE IF NOT EXISTS `posts` (`title`, `date`, PRIMARY KEY (`author`, `date`));") - - (check-equal? (make-insert/replace-query 'posts '(author title)) - (string-append "INSERT OR REPLACE INTO `posts` (`rowid`, `author`, `title`) " - "VALUES ((SELECT `rowid` FROM `posts` WHERE `author`= ?1), ?1, ?2)")) - - (check-equal? (make-insert-rows-query 'series '(id name num) '((1 "Journal" 11) (2 "Ideas" 4))) - (string-append "INSERT INTO `series` (`id`, `name`, `num`) " - "VALUES (1, \"Journal\", 11), (2, \"Ideas\", 4);")) - - (check-equal? (make-select-query 'posts '(author title) #:where 1) - "SELECT `author`, `title` FROM `posts` WHERE 1")) - -(define (good-connection?) - (and (connection? (sqltools:dbc)) (connected? (sqltools:dbc)))) - -;; Initialize the database connection, creating the database if it does not yet exist -;; and running any provided queries (e.g., "CREATE TABLE IF NOT EXISTS...") -(define (init-db! filename . qs) - (cond [(good-connection?) (disconnect (sqltools:dbc))]) - (sqltools:dbc (sqlite3-connect #:database filename #:mode 'create)) - (unless (empty? qs) - (for ([q (in-list qs)]) - (query! q)))) - -;; Run a query with logging (if enabled) and return the result -(define (query! q . parameters) - (unless (good-connection?) (error "(query!) DB not connected")) - (log-query q) - (cond [(empty? parameters) (query-exec (sqltools:dbc) q)] - [else (apply query-exec (sqltools:dbc) q parameters)])) - -;; Run a SELECT query, return a hash with field names as keys -(define select-rows! - (case-lambda - ;; Use arbitrary query - [(query fieldnames) - (unless (good-connection?) (error "(select-rows!) DB not connected")) - (log-query query) - (define result (query-rows (sqltools:dbc) query)) - (map (curryr vector->hash fieldnames) result)] - - ;; Use a simple SELECT FROM WHERE template - [(table fields where-clause) - (unless (good-connection?) (error "(select-rows!) DB not connected")) - (define query (make-select-query table fields #:where where-clause)) - (log-query query) - (define result (query-rows (sqltools:dbc) query)) - (map (curryr vector->hash fields) result)])) - -;; TESTING: database connection state and queries -(module+ test - (define TESTDB "SQLITE-TOOLS-TEST.sqlite") - - ;; Check that things start out uninitialized and that queries don’t work - (check-equal? (sqltools:dbc) uninitialized-connection) - (check-false (file-exists? TESTDB)) - (check-exn exn:fail? (lambda () (query! "SELECT 1"))) - (check-exn exn:fail? (lambda () (select-rows! 'posts '(title) 1))) - - ;; Initialize db connection, create file with no schema - (test-begin - (check-equal? (init-db! TESTDB) (void)) - (check-true (file-exists? TESTDB)) - (delete-file TESTDB)) - - ;; Initialize new db/connection, create file with schema, check that - ;; simple queries return expected results - (test-begin - (check-equal? (init-db! TESTDB (make-table-schema 'posts '(title date))) (void)) - (check-true (file-exists? TESTDB)) - (check-equal? (select-rows! (make-select-query 'posts '(title date) #:where 1) '(title date)) null) - (check-equal? (query! (make-insert/replace-query 'posts '(title date)) "Hello" "2018-08-10") (void)) - (check-equal? (select-rows! 'posts '(title date) "`date`='2018-08-10'") - '(#hash((title . "Hello") (date . "2018-08-10"))))) - - ;; Clean up - (disconnect (sqltools:dbc)) - (sqltools:dbc uninitialized-connection) - (delete-file TESTDB)) Index: template.html.p ================================================================== --- template.html.p +++ template.html.p @@ -1,17 +1,15 @@ ◊; SPDX-License-Identifier: BlueOak-1.0.0 ◊; This file is licensed under the Blue Oak Model License 1.0.0. - -◊(define article-html (crystalize-article! here doc)) -◊(define page-title (article-plain-title here)) -◊html$-page-head[page-title] +◊(define article-html (parse-and-cache-article! here doc)) +◊html$-page-head[(current-plain-title)] ◊html$-page-body-open[] ◊article-html ◊html$-page-body-close[]