#lang racket/base ;; Copyright (c) 2018 Joel Dueck. ;; ;; Licensed under the Apache License, Version 2.0 (the "License"); ;; you may not use this file except in compliance with the License. ;; A copy of the License is included with this source code, in the ;; file "LICENSE.txt". ;; You may also obtain a copy of the License at ;; ;; http://www.apache.org/licenses/LICENSE-2.0 ;; ;; Unless required by applicable law or agreed to in writing, software ;; distributed under the License is distributed on an "AS IS" BASIS, ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;; See the License for the specific language governing permissions and ;; limitations under the License. ;; ;; Author contact information: ;; joel@jdueck.net ;; https://joeldueck.com ;; ------------------------------------------------------------------------- ;; 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 pollen/template racket/string racket/function txexpr db/base "sqlite-tools.rkt" "snippets-html.rkt" "dust.rkt") ;; ~~~ Provides ~~~ (provide spell-of-summoning! crystalize-article! article-plain-title list-short/articles list-full/articles list-full/articles+notes unfence 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 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_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)) ;; ~~~ 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)) ;; 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-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) maybe-title)] [title-tx (make-article-title 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 title-specified? title-tx pubdate)] [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)]) ;; 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 (symbol->string pagenode) pubdate title-plain))) ; listing_short_html: Not yet used (apply query! (make-insert/replace-query 'articles table_articles-fields) article-record) (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 ""])) ;; (private) 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` FROM `articles` UNION SELECT `~a`,`date` AS `published` FROM `notes` ~a ORDER BY `published` ~a LIMIT ~a) @@@@@ ) (query-list (sqltools:dbc) (format select type type type (where/series s) order limit))) ;; (private) 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 (list-short/articles #:series [s #t] #:limit [limit -1] [order "DESC"]) `(style "")) (define (list-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 (list-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 ~~~ ;; ;; Return a title txexpr for the current article, constructing a default if no title text was specified. (define (make-article-title supplied-title body-tx disposition disp-note-id) (define title-elems (cond [(null? supplied-title) (list (default-title (get-elements body-tx)))] [else (get-elements supplied-title)])) (define disposition-part (cond [(non-empty-string? disposition) (define-values (mark _) (disposition-values disposition)) `(span [[class "disposition-mark"]] (a [[href ,(string-append "#" 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 ""])) (define disp-part (cond [(non-empty-string? disposition) (define-values (mark verb) (disposition-values disposition)) (format "Now considered ~a." pagenode disp-note-id verb)] [else ""])) (define notes-part (cond [(note-count . > . 1) (format "There are ~a notes appended." pagenode note-count)] [(and (note-count . > . 0) (string=? disposition "")) (format "There is a note appended." pagenode)] [else ""])) (cond [(andmap non-empty-string? (list series-part disp-part notes-part)) (format "~a ~a ~a" 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)] [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-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))) (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)) (define note-id (build-note-id note-tx)) (define title-html-flow (html$-note-title author pagenode parent-title-plain)) (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 (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 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)) (define (article-plain-title pagenode) (query-value (sqltools:dbc) "SELECT `title_plain` FROM `articles` WHERE `pagenode` = ?1" (symbol->string pagenode))) ;; ~~~ 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))