#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/articles
list/articles+notes
listing<>-short/articles
listing<>-full/articles
listing<>-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 pagenode 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 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 ""]))
;; 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)))
;; 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 "<ul class=\"article-list\">"
,@(list/articles "listing_short_html" #:series s #:limit limit order)
"</ul>"))
(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 "<style>" and "</style>" 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 "<span class=\"series-part\">This is ~a, part of <a href=\"/~a\">‘~a’</a>.</span>"
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>."
pagenode
disp-note-id
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 [(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)]
[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 default-authorname))
(define note-id (build-note-id note-tx))
(define title-html-flow (html$-note-title 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))
