#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 racket/match racket/string txexpr pollen/template (except-in pollen/core select) ; avoid conflict with deta ) (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))) (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)] [header (html$-article-open pagenode title-specified? title-tx pubdate)] [series-node (metas-series-pagenode)] [footertext (make-article-footertext pagenode series-node disposition disp-note-id (length note-txprs))] [footer (html$-article-close footertext)] [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) (delete-article! pagenode) (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))) (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)))] [else (get-elements supplied-title)])) (define disposition-part (cond [(non-empty-string? disposition) (define-values (mark _) (disposition-values disposition)) `(a [[class "disposition-mark"] [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 series-part (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 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 [(ormap non-empty-string? (list series-part disp-part notes-part)) (string-join (list series-part disp-part notes-part))] [else ""])) ;; ~~~ Notes ~~~ (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 (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) (>= (length (string-split disposition-attr)) 2)) (raise-arguments-error 'note "must be in format \"[symbol] [past-tense-verb]\"" "disposition attr" disposition-attr)) (define-values (disp-mark disp-verb) (disposition-values disposition-attr)) (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) #:conceal (or (maybe-attr 'conceal attrs #f) (maybe-meta 'conceal)) #: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))) ;; ~~~ 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" "") ;; "entry!sub" → '("entry" "sub") ;; "entry!sub!why?!? '("entry" "sub") (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 (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-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)))))) ;; 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))) (query-exec cache-conn (delete (~> (from cache:series #:as s) (where (= s.page ,here-page))))) (void (insert-one! cache-conn (make-cache:series #:page (string->symbol here-page) #: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 "")))))