#lang pollen/mode 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
txexpr
"sqlite-tools.rkt"
"snippets-html.rkt"
"dust.rkt")
;; ~~~ Provides ~~~
(provide spell-of-summoning!
crystalize-article!
article-plain-title)
;; ~~~ 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
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))
;; Split all ◊note tags out of the Pollen doc
(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 and its notes (if any) to the database, and return the
;; rendered HTML of the complete article.
;;
(define (crystalize-article! pagenode doc)
(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 title-specified? (non-empty-string? (maybe-meta 'title)))
(define-values (title-plain title-html-flow)
(title-plain+html-values body-txpr disposition))
(define series-node (maybe-meta 'series))
(define header (html$-article-open title-specified? title-html-flow pubdate))
(define footertext (make-article-footertext pagenode series-node disposition disp-note-id (length note-txprs)))
(define footer (html$-article-close footertext))
(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
(bool->int title-specified?)
pubdate
(maybe-meta 'updated)
(maybe-meta 'author default-authorname)
(maybe-meta 'conceal)
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
"")) ; 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})
;; ~~~ Article-related helper functions ~~~
;;
;; Return both a plain-text and HTML version of a title for the current article,
;; supplying a default if no title was specified in the metas.
(define (title-plain+html-values body-tx disposition)
(define title (maybe-meta 'title ""))
(define title-val
(cond [(and (string? title) (string=? title ""))
(format "“~a…”" (first-words (tx-strs body-tx) 5))]
[else title]))
(define disposition-part
(cond [(non-empty-string? disposition)
(define-values (mark _) (disposition-values disposition))
(format "<span class=\"disposition-mark\">~a</span>" 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))]))
;; 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 href=\"/~a\">‘~a’</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 href=\"/~a#~a\">~a ~a</a>."
pagenode
disp-note-id
mark
verb)]
[else ""]))
(define notes-part
(cond [(note-count . > . 1)
(format "There are <a href=\"/~a#furthernotes\">~a notes</a> appended."
pagenode
note-count)]
[(and (note-count . > . 0) (string=? disposition ""))
(format "There is <a href=\"/~a#furthernotes\">a note</a> 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
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)))
