suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

db: more db/../function updates, factor out checks better

Browse Source
This commit is contained in:
Ryan Culpepper 2017-04-08 14:37:14 -04:00
parent 7c50113ced
commit 1e40af55bc
1 changed files with 63 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
racket/collects/db/private/generic/functions.rkt
View File

@ -15,6 +15,7 @@
(define (disconnect x) (define (disconnect x)
(send x disconnect)) (send x disconnect))
;; == Statements ;; == Statements
(define (statement? x) (define (statement? x)
@ -54,117 +55,107 @@
;; == Query helper procedures ;; == Query helper procedures
;; query1 : connection symbol Statement -> QueryResult ;; ResultCheck = #f | 'rows | exact-positive-integer
(define (query1 c fsym stmt) ;; #f = no check, 'rows = want rows-result, n = want rows-result w/ n cols
(send c query fsym stmt #f))
;; query/rows : connection symbol Statement nat/#f -> rows-result ;; query1 : Connection Symbol Statement -> QueryResult
(define (query/rows c fsym sql want-columns) (define (query1 c who stmt)
(let [(result (query1 c fsym sql))] (send c query who stmt #f))
(unless (rows-result? result)
(error/want-rows fsym sql #t))
(let ([got-columns (length (rows-result-headers result))])
(when (and want-columns (not (= got-columns want-columns)))
(error/column-count fsym sql want-columns got-columns #t)))
result))
(define (query/cursor c fsym sql want-columns) ;; query/rows : Connection Symbol Statement Nat/#f -> Rows-Result
(let ([result (send c query fsym sql #t)]) (define (query/rows c who stmt want-columns)
(unless (cursor-result? result) (check-rows-result who stmt want-columns (query1 c who stmt)))
(error/want-cursor fsym sql))
(let ([got-columns (length (cursor-result-headers result))])
(when (and want-columns (not (= got-columns want-columns)))
(error/column-count fsym sql want-columns got-columns #t)))
result))
(define (rows-result->row fsym rs sql maybe-row? one-column?) ;; check-rows-result : Symbol Statement ResultCheck Query-Result -> Rows-Result
(define rows (rows-result-rows rs)) (define (check-rows-result who sql want-columns result)
(unless (rows-result? result)
(error/want-rows who sql #t))
(let ([got-columns (length (rows-result-headers result))])
(when (and (exact-integer? want-columns) (not (= got-columns want-columns)))
(error/column-count who sql want-columns got-columns #t)))
result)
;; rows-result->row : Symbol Rows-Result Statement Boolean Boolean -> Vector/Any
(define (rows-result->row who result sql maybe-row? one-column?)
(define rows (rows-result-rows result))
(cond [(null? rows) (cond [(null? rows)
(cond [maybe-row? #f] (if maybe-row? #f (error/row-count who sql 1 0))]
[else (error/row-count fsym sql 1 0)])]
[(null? (cdr rows)) [(null? (cdr rows))
(let ([row (car rows)]) (let ([row (car rows)])
(cond [one-column? (vector-ref row 0)] (if one-column? (vector-ref row 0) row))]
[else row]))] [else (error/row-count who sql 1 (length rows))]))
[else (error/row-count fsym sql 1 (length rows))]))
(define (compose-statement fsym c stmt args checktype) ;; compose-statement : Symbol Connection Statement List ResultCheck -> Statement
;; Returns self-contained statement: either string or statement-binding.
(define (compose-statement who c stmt args checktype)
(cond [(prop:statement? stmt) (cond [(prop:statement? stmt)
(let ([stmt* ((prop:statement-ref stmt) stmt c)]) (let ([stmt* ((prop:statement-ref stmt) stmt c)])
(compose-statement fsym c stmt* args checktype))] (compose-statement who c stmt* args checktype))]
[(or (pair? args) [(or (pair? args) (prepared-statement? stmt))
(prepared-statement? stmt)) (define pst
(let ([pst (cond [(string? stmt)
(cond [(string? stmt) (prepare1 who c stmt #t)]
(prepare1 fsym c stmt #t)] [(prepared-statement? stmt)
[(prepared-statement? stmt) ;; Ownership check done later, by query method.
;; Ownership check done later, by query method. stmt]
stmt] [(statement-binding? stmt)
[(statement-binding? stmt) (error/statement-binding-args who stmt args)]))
(error/statement-binding-args fsym stmt args)])]) (send pst check-results who checktype stmt)
(send pst check-results fsym checktype stmt) (send pst bind who args)]
(send pst bind fsym args))]
[else ;; no args, and stmt is either string or statement-binding [else ;; no args, and stmt is either string or statement-binding
stmt])) stmt]))
;; query-row* : Symbol Connection Statement List Nat/#f Boolean Boolean -> (varies)
;; Helper for all query operations that expect at most one row returned.
(define (query-row* who c sql args want-columns maybe-row? one-column?)
(let* ([sql (compose-statement who c sql args (or want-columns 'rows))]
[result (query/rows c who sql want-columns)])
(rows-result->row who result sql maybe-row? one-column?)))
;; == Query API procedures ;; == Query API procedures
;; query-rows0 : connection Statement arg ... -> (listof (vectorof 'a)) ;; query-rows0 : connection Statement arg ... -> (listof (vectorof 'a))
(define (query-rows0 c sql . args) (define (query-rows0 c sql . args)
(let* ([sql (compose-statement 'query-rows c sql args 'rows)] (let* ([sql (compose-statement 'query-rows c sql args 'rows)]
[result (query/rows c 'query-rows sql #f)]) [result (query/rows c 'query-rows0 sql #f)])
(rows-result-rows result))) (rows-result-rows result)))
;; query-list : connection Statement arg ... -> (listof 'a) ;; query-list : connection Statement arg ... -> (listof 'a)
;; Expects to get back a rows-result with one field per row. ;; Expects to get back a rows-result with one field per row.
(define (query-list c sql . args) (define (query-list c sql . args)
(let ([sql (compose-statement 'query-list c sql args 1)]) (let* ([sql (compose-statement 'query-list c sql args 1)]
(map (lambda (v) (vector-ref v 0)) [result (query/rows c 'query-list sql 1)])
(rows-result-rows (query/rows c 'query-list sql 1))))) (map (lambda (v) (vector-ref v 0)) (rows-result-rows result))))
;; query-row : connection Statement arg ... -> (vector-of 'a) ;; query-row : Connection Statement SqlDatum ... -> (Vectorof SqlDatum)
;; Expects to get back a rows-result of zero or one rows.
(define (query-row c sql . args) (define (query-row c sql . args)
(let ([sql (compose-statement 'query-row c sql args 'rows)]) (query-row* 'query-row c sql args #f #f #f))
(rows-result->row 'query-row
(query/rows c 'query-row sql #f)
sql #f #f)))
;; query-maybe-row : connection Statement arg ... -> (vector-of 'a) or #f ;; query-maybe-row : Connection Statement SqlDatum ... -> (Vectorof SqlDatum) or #f
;; Expects to get back a rows-result of zero or one rows.
(define (query-maybe-row c sql . args) (define (query-maybe-row c sql . args)
(let ([sql (compose-statement 'query-maybe-row c sql args 'rows)]) (query-row* 'query-maybe-row c sql args #f #t #f))
(rows-result->row 'query-maybe-row
(query/rows c 'query-maybe-row sql #f)
sql #t #f)))
;; query-value : connection string arg ... -> value | raises error ;; query-value : Connection Statement SqlDatum ... -> SqlDatum | raises error
;; Expects to get back a rows-result of exactly one row, exactly one column.
(define (query-value c sql . args) (define (query-value c sql . args)
(let ([sql (compose-statement 'query-value c sql args 1)]) (query-row* 'query-value c sql args 1 #f #t))
(rows-result->row 'query-value
(query/rows c 'query-value sql 1)
sql #f #t)))
;; query-maybe-value : connection Statement arg ... -> value/#f ;; query-maybe-value : Connection Statement SqlDatum ... -> SqlDatum or #f
;; Expects to get back a rows-result of zero or one rows, exactly one column.
(define (query-maybe-value c sql . args) (define (query-maybe-value c sql . args)
(let ([sql (compose-statement 'query-maybe-value c sql args 1)]) (query-row* 'query-maybe-value c sql args 1 #t #t))
(rows-result->row 'query-maybe-value
(query/rows c 'query-maybe-value sql 1)
sql #t #t)))
;; query-exec : connection Statement arg ... -> void ;; query-exec : Connection Statement SqlDatum ... -> void
(define (query-exec c sql . args) (define (query-exec c sql . args)
(let ([sql (compose-statement 'query-exec c sql args #f)]) (let ([sql (compose-statement 'query-exec c sql args #f)])
(query1 c 'query-exec sql) (query1 c 'query-exec sql)
(void))) (void)))
;; query : connection Statement arg ... -> QueryResult ;; query : Connection Statement SqlDatum ... -> QueryResult
(define (query c sql . args) (define (query c sql . args)
(let ([sql (compose-statement 'query c sql args #f)]) (let ([sql (compose-statement 'query c sql args #f)])
(query1 c 'query sql))) (query1 c 'query sql)))
;; == Prepare ;; == Prepare
(define (prepare c stmt) (define (prepare c stmt)
@ -175,6 +166,7 @@
;; stmt is string ;; stmt is string
(send c prepare fsym stmt close-on-exec?)) (send c prepare fsym stmt close-on-exec?))
;; == Transactions ;; == Transactions
(define (start-transaction c (define (start-transaction c