#lang racket/base
; SPDX-License-Identifier: BlueOak-1.0.0
; This file is licensed under the Blue Oak Model License 1.0.0.
;; 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-values ((listof stringish?) . -> . string?)]
[list->sql-parameters ((listof any/c) . -> . string?)]
[bool->int (any/c . -> . exact-integer?)]
[int->bool (exact-integer? . -> . boolean?)]
;; Simple SQL makers
[make-table-schema ((string? (listof stringish?))
(#:primary-key-cols (listof stringish?))
. ->* . string?)]
[make-insert/replace-query (stringish? (listof stringish?) . -> . string?)]
[make-insert-rows-query (stringish? (listof stringish?) (listof (listof stringish?)) . -> . string?)]
[make-select-query (stringish? (listof stringish?) #:where stringish? . -> . 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))))
(define (sql-val v)
(cond [(string? v) (string-append "\"" v "\"")]
[else (format "~a" v)]))
;; ~~~ 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-values vals)
(string-append "(" (apply string-append (add-between (map sql-val vals) ", ")) ")"))
(define (list->sql-parameters fields)
(apply string-append (add-between (map (λ(x) (format "?~a" (add1 x))) (range (length fields))) ", ")))
;; For storing/reading boolean values (SQLite uses integers)
(define (bool->int b?)
(cond [b? 1] [else 0]))
(define (int->bool i)
(not (= i 0)))
;; 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? (list->sql-values '(100 "hello" 3)) "(100, \"hello\", 3)")
(check-equal? (weave '(x y z) '(1 2 3)) '(x 1 y 2 z 3))
(check-equal? (bool->int #f) 0)
(check-equal? (bool->int #t) 1)
(check-equal? (bool->int "xblargh") 1)
(check-equal? (int->bool 0) #f)
(check-equal? (int->bool 1) #t)
(check-equal? (int->bool -1) #t)
(check-equal? (int->bool 37) #t)
(check-exn exn:fail? (lambda () (int->bool "x"))))
;; ~~~ 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)))
;; Create a query that inserts multiple rows.
(define (make-insert-rows-query tablename fields rows)
(define row-values
(apply string-append (add-between (map list->sql-values rows) ", ")))
(format "INSERT INTO `~a` (~a) VALUES ~a;" tablename (list->sql-fields fields) row-values))
;; 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-insert-rows-query 'series '(id name num) '((1 "Journal" 11) (2 "Ideas" 4)))
(string-append "INSERT INTO `series` (`id`, `name`, `num`) "
"VALUES (1, \"Journal\", 11), (2, \"Ideas\", 4);"))
(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)
(cond [(good-connection?) (disconnect (sqltools:dbc))])
(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)
(cond [(empty? parameters) (query-exec (sqltools:dbc) q)]
[else (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! "SELECT 1")))
(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))
