Local Yarn Code

Artifact Content

Artifact f4b3e60340a7fd85af5b7d5ddd19ff293fcef974babe5dd15eb5eb227259c5e0:


#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))