#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
pollen/pagetree
racket/string
txexpr
"sqlite-tools.rkt"
"template-html.rkt"
"dust.rkt")
;; ~~~ Provides ~~~
(provide spell-of-summoning!
crystalize-article!)
;; ~~~ 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
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))
(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-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 "<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))]))
(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))
