@@ -34,13 +34,14 @@ (require pollen/setup pollen/core pollen/template pollen/pagetree racket/string + txexpr "sqlite-tools.rkt" "template-html.rkt" - "dates.rkt") + "dust.rkt") ;; ~~~ Provides ~~~ (provide spell-of-summoning! crystalize-article!) @@ -47,77 +48,174 @@ ;; ~~~ 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 + title_plain + title_html_flow published updated - doc_html author conceal series_pagenode noun_singular - note_count)) + 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 - heading + note_id + title_html_flow author + author_url date - note_html)) + disposition + content_html + 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_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 (optional-meta m) - (or (select-from-metas m (current-metas)) "")) - -(define (series-noun) - (define series-pagenode (->pagenode (or (select-from-metas 'series (current-metas)) ""))) - (case series-pagenode - ['|| ""] ; no series specified - [else (or (select-from-metas 'noun-singular series-pagenode) "")])) +(define (doc->body/notes doc) + (define (is-note? tx) (and (txexpr? tx) (equal? 'note (get-tag tx)))) + (splitf-txexpr doc is-note?)) ;; ~~~ 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 (using current-doc and current-metas) and its notes (if any) -;; to the database, and return the rendered HTML. +;; 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 header (html-article-header)) - (define footer (html-article-footer)) - (define body (->html (cdr doc))) - ;; TK: store notes separately - - (define saving-query (make-insert/replace-query 'articles table_articles-fields)) - (query! saving-query - (symbol->string pagenode) - (optional-meta 'title) - (select-from-metas 'published (current-metas)) - (optional-meta 'updated) - (string-append header body footer) - (optional-meta 'author) - (optional-meta 'conceal) - (optional-meta 'series) - (series-noun) - 0) ; note_count - - `(@ ,header ,body ,footer)) - + (define pubdate (select-from-metas 'published (current-metas))) + (define-values (body-txpr note-txprs) (doc->body/notes doc)) + (define doc-html (->html (cdr body-txpr))) + + (define-values (disposition disp-note-id) + (notes->last-disposition-values note-txprs)) + (define-values (title-plain title-html-flow) + (make-article-titles (maybe-meta 'title (default-title pubdate)) (report disposition))) + (define header (html$-article-open title-html-flow pubdate)) + (define footer (html$-article-close)) + + (define 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-flow + pubdate + (maybe-meta 'updated) + (maybe-meta 'author default-authorname) + (maybe-meta 'conceal) + (maybe-meta 'series) + (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 + "")) ; 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}) + +(define (make-article-titles title-val disposition) + (define disposition-part + (cond [(non-empty-string? disposition) + (define-values (mark _) (disposition-values disposition)) + (format "~a" mark)] + [else ""])) + + (cond [(txexpr? title-val) + (values (apply string-append (tx-strs title-val)) + (string-append (->html title-val) disposition-part))] + [else (values title-val (string-append title-val disposition-part))])) + +(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 ""])) + +(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 author author-url content-html)) + + (define note-record + (list pagenode + note-id + title-html-flow + author + author-url + note-date + disposition-attr + content-html + 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 author author-url content-html))