ADDED crystalize.rkt Index: crystalize.rkt ================================================================== --- crystalize.rkt +++ crystalize.rkt @@ -0,0 +1,123 @@ +#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 + "sqlite-tools.rkt" + "template-html.rkt" + "dates.rkt") + +;; ~~~ Provides ~~~ + +(provide spell-of-summoning! + crystalize-article!) + +;; ~~~ Private use ~~~ + +(define DBFILE (build-path (current-project-root) "vitreous.sqlite")) + +(define table_articles-fields + '(pagenode + title + published + updated + doc_html + author + conceal + series_pagenode + noun_singular + note_count)) + +(define table_notes-fields + '(pagenode + note-id + heading + author + date + note_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 (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) "")])) + +;; ~~~ 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. +;; +(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)) + Index: pollen.rkt ================================================================== --- pollen.rkt +++ pollen.rkt @@ -30,23 +30,25 @@ (require pollen/tag pollen/setup racket/function "tags-html.rkt" - "template-html.rkt") + "template-html.rkt" + "crystalize.rkt") (provide (all-defined-out) - (all-from-out "template-html.rkt")) + (all-from-out "crystalize.rkt" "template-html.rkt")) (module setup racket/base (require syntax/modresolve) (provide (all-defined-out)) (define poly-targets '(html)) (define cache-watchlist (map resolve-module-path '("tags-html.rkt" "template-html.rkt" - "dates.rkt")))) + "dates.rkt" + "crystalize.rkt")))) ;; Macro for defining tag functions that automatically branch based on the ;; current output format and the list of poly-targets in the setup module. ;; (define-syntax (poly-branch-tag stx) ADDED sqlite-tools.rkt Index: sqlite-tools.rkt ================================================================== --- sqlite-tools.rkt +++ sqlite-tools.rkt @@ -0,0 +1,237 @@ +#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 a very light set of utility functions for a SQLite database. +;; These functions are completely agnostic as to the database schema. +;; These functions are NOT SAFE for use with data provided by untrusted users! + +(require db/sqlite3 + db/base + racket/list + racket/match + racket/function + racket/contract + sugar/coerce) + +(module+ test + (require rackunit)) + +(provide sqltools:dbc + sqltools:log-queries?) + +(provide + (contract-out + ;; Utility functions + [log-query (string? . -> . void?)] + [vector->hash (vector? (listof symbolish?) . -> . hash?)] + [backtick (stringish? . -> . string?)] + [list->sql-fields ((listof stringish?) . -> . string?)] + [list->sql-parameters ((listof any/c) . -> . string?)] + + ;; Simple SQL makers + [make-table-schema ((string? (listof stringish?)) + (#:primary-key-cols (listof stringish?)) + . ->* . string?)] + [make-insert/replace-query (stringish? (listof stringish?) . -> . string?)] + [make-select-query (stringish? (listof stringish?) #:where string? . -> . string?)] + + ;; Database operations + [init-db! ((pathish?) #:rest (listof string?) . ->* . void?)] + [query! ((string?) #:rest (listof any/c) . ->* . void?)] + [select-rows! (case-> + (stringish? (listof stringish?) any/c . -> . (or/c empty? hash?)) + (string? (listof stringish?) . -> . (or/c empty? hash?)))])) + +;; ~~~ Private use ~~~ + +(define uninitialized-connection "No DB connection!") +(define (weave xs ys) + (for/fold [(woven null) + #:result (reverse woven)] + ([x (in-list xs)] + [y (in-list ys)]) + (cons y (cons x woven)))) + +;; ~~~ Provided parameters ~~~ + +(define sqltools:dbc (make-parameter uninitialized-connection)) +(define sqltools:log-queries? (make-parameter #f)) + +;; ~~~ Provided utility functions ~~~ + +(define (backtick str) (format "`~a`" str)) +(define (list->sql-fields fields) (apply string-append (add-between (map backtick fields) ", "))) +(define (list->sql-parameters fields) + (apply string-append (add-between (map (λ(x) (format "?~a" (add1 x))) (range (length fields))) ", "))) + +;; TESTING: utility functions… +(module+ test + (check-equal? (backtick "field") "`field`") + (check-equal? (list->sql-fields '("f1" "f2" "f3")) "`f1`, `f2`, `f3`") + (check-equal? (list->sql-fields '(f1 f2 f3)) "`f1`, `f2`, `f3`") ; Can use symbols too + (check-equal? (list->sql-parameters '("name" "rank" "serial")) "?1, ?2, ?3") + (check-equal? (list->sql-parameters '(name rank serial)) "?1, ?2, ?3") + (check-equal? (weave '(x y z) '(1 2 3)) '(x 1 y 2 z 3))) + +;; ~~~ Public functions ~~~ + +;; Prints to stdout if logging is on +(define (log-query q) (unless (not (sqltools:log-queries?)) (println q))) + +;; Using a list of field names, convert a vector into a hash that uses the +;; field names (in symbol form) for keys. +;; Racket’s db functions all return vectors; hashes are much easier to use. +;; If fields and v are not equal in length, the unpairable elements are omitted +;; from the hash! +(define (vector->hash v fields) + (cond [(zero? (vector-length v)) null] + [else (let ([keys (map ->symbol fields)] + [vals (vector->list v)]) + (apply hash (weave keys vals)))])) + +;; TESTING: vector->hash... +(module+ test + (let ([test-row '#("Joe" "PFC" 123)] + [test-cols-SYMBOL '(name rank serial)] + [test-cols-STRING '("name" "rank" "serial")] + [desired-result '#hash((serial . 123) (rank . "PFC") (name . "Joe"))]) + (check-equal? (vector->hash test-row test-cols-SYMBOL) desired-result) + (check-equal? (vector->hash test-row test-cols-STRING) desired-result)) + + ;; Behavior when v and fields are unequal in length: + (check-equal? (vector->hash '#("foo" "bar") '(a b c)) + '#hash((a . "foo") (b . "bar"))) + (check-equal? (vector->hash '#("foo" "bar" "baz") '(a b)) + '#hash((a . "foo") (b . "bar")))) + +;; Create a simple table schema from a list of fields, optionally specifying +;; primary key +(define (make-table-schema tablename fields #:primary-key-cols [primary-cols '()]) + (define primary-key + (format "PRIMARY KEY (~a)" + (list->sql-fields (if (empty? primary-cols) (list (first fields)) primary-cols)))) + (format "CREATE TABLE IF NOT EXISTS `~a` (~a, ~a);" + tablename + (list->sql-fields fields) + primary-key)) + +;; Create a query that inserts a row if it doesn’t exist (based on the first +;; column only), or updates it if it does. The returned query is parameterized, +;; and must be used with a list of values equal in length to the number of +;; fields given. +(define (make-insert/replace-query tablename fields) + (format "INSERT OR REPLACE INTO `~a` (`rowid`, ~a) values ((SELECT `rowid` FROM `~a` WHERE `~a`= ?1), ~a)" + tablename + (list->sql-fields fields) + tablename + (first fields) + (list->sql-parameters fields))) + +;; Simple row selection +(define (make-select-query table fields #:where where-clause) + (format "SELECT ~a FROM `~a` WHERE ~a" + (list->sql-fields fields) + table + where-clause)) + +;; TESTING: SQL query makers... +(module+ test + (check-equal? (make-table-schema 'posts '(title date)) + "CREATE TABLE IF NOT EXISTS `posts` (`title`, `date`, PRIMARY KEY (`title`));") + (check-equal? (make-table-schema "posts" '("title" "date")) + "CREATE TABLE IF NOT EXISTS `posts` (`title`, `date`, PRIMARY KEY (`title`));") + (check-equal? (make-table-schema 'posts '(title date) #:primary-key-cols '(author date)) + "CREATE TABLE IF NOT EXISTS `posts` (`title`, `date`, PRIMARY KEY (`author`, `date`));") + + (check-equal? (make-insert/replace-query 'posts '(author title)) + (string-append "INSERT OR REPLACE INTO `posts` (`rowid`, `author`, `title`) " + "values ((SELECT `rowid` FROM `posts` WHERE `author`= ?1), ?1, ?2)")) + + (check-equal? (make-select-query 'posts '(author title) #:where 1) + "SELECT `author`, `title` FROM `posts` WHERE 1")) + +(define (good-connection?) + (and (connection? (sqltools:dbc)) (connected? (sqltools:dbc)))) + +;; Initialize the database connection, creating the database if it does not yet exist +;; and running any provided queries (e.g., "CREATE TABLE IF NOT EXISTS...") +(define (init-db! filename . qs) + (sqltools:dbc (sqlite3-connect #:database filename #:mode 'create)) + (unless (empty? qs) + (for ([q (in-list qs)]) + (query! q)))) + +;; Run a query with logging (if enabled) and return the result +(define (query! q . parameters) + (unless (good-connection?) (error "(query!) DB not connected")) + (log-query q) + (apply query-exec (sqltools:dbc) q parameters)) + +;; Run a SELECT query, return a hash with field names as keys +(define select-rows! + (case-lambda + ;; Use arbitrary query + [(query fieldnames) + (unless (good-connection?) (error "(select-rows!) DB not connected")) + (log-query query) + (define result (query-rows (sqltools:dbc) query)) + (map (curryr vector->hash fieldnames) result)] + + ;; Use a simple SELECT FROM WHERE template + [(table fields where-clause) + (unless (good-connection?) (error "(select-rows!) DB not connected")) + (define query (make-select-query table fields #:where where-clause)) + (log-query query) + (define result (query-rows (sqltools:dbc) query)) + (map (curryr vector->hash fields) result)])) + +;; TESTING: database connection state and queries +(module+ test + (define TESTDB "SQLITE-TOOLS-TEST.sqlite") + + ;; Check that things start out uninitialized and that queries don’t work + (check-equal? (sqltools:dbc) uninitialized-connection) + (check-false (file-exists? TESTDB)) + (check-exn exn:fail? (lambda () (query! "-- nothing"))) + (check-exn exn:fail? (lambda () (select-rows! 'posts '(title) 1))) + + ;; Initialize db connection, create file with no schema + (test-begin + (check-equal? (init-db! TESTDB) (void)) + (check-true (file-exists? TESTDB)) + (delete-file TESTDB)) + + ;; Initialize new db/connection, create file with schema, check that + ;; simple queries return expected results + (test-begin + (check-equal? (init-db! TESTDB (make-table-schema 'posts '(title date))) (void)) + (check-true (file-exists? TESTDB)) + (check-equal? (select-rows! (make-select-query 'posts '(title date) #:where 1) '(title date)) null) + (check-equal? (query! (make-insert/replace-query 'posts '(title date)) "Hello" "2018-08-10") (void)) + (check-equal? (select-rows! 'posts '(title date) "`date`='2018-08-10'") + '(#hash((title . "Hello") (date . "2018-08-10"))))) + + ;; Clean up + (disconnect (sqltools:dbc)) + (sqltools:dbc uninitialized-connection) + (delete-file TESTDB)) Index: template-html.rkt ================================================================== --- template-html.rkt +++ template-html.rkt @@ -25,46 +25,47 @@ (require pollen/core "dates.rkt") (provide (all-defined-out)) -(define (ht-head [title #f]) +(define (html-head [title #f]) ◊@{ The Local Yarn◊when/splice[title]{: ◊title} }) -(define (ht-page-top) +(define (html-page-top) ◊@{

The Local Yarn

}) -(define (ht-article-header) +(define (html-article-header) (define title (select-from-metas 'title (current-metas))) (define published (select-from-metas 'published (current-metas))) (cond [title - ◊@{
+ ◊string-append{

◊|title|

}] [else - ◊@{
+ ◊string-append{
(Part of ‘Talking About Poetry’. Once I threw a mudball at a birdhouse. I’m not exactly proud of it, though.)
}) - -(define (ht-page-bottom) + + +(define (html-page-bottom) ◊@{
}) Index: template.html.p ================================================================== --- template.html.p +++ template.html.p @@ -1,14 +1,13 @@ -◊ht-head[(select-from-metas 'title here)] - -◊ht-page-top[] - -◊ht-article-header[] -◊(->html (cdr doc)) -◊ht-article-footer[] - -◊ht-page-bottom[] +◊html-head[(select-from-metas 'title here)] + +◊html-page-top[] + +◊spell-of-summoning![] +◊crystalize-article![here doc] + +◊html-page-bottom[]