[db] split postgres helper functions
This commit is contained in:
ben
parent
57f857843f
commit
ada69b0d58
170
private/db.rkt
170
private/db.rkt
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
(provide
|
||||
(all-from-out db)
|
||||
|
||||
|
||||
;(rename-out [quasiquote DB]) ;; TODO try using struct types
|
||||
|
||||
define-schema:
|
||||
|
|
@ -27,16 +27,12 @@
|
|||
(for-syntax
|
||||
typed/racket/base
|
||||
racket/syntax
|
||||
(only-in racket/string string-split)
|
||||
;; --- query
|
||||
(only-in racket/port with-input-from-string)
|
||||
(only-in racket/format ~a)
|
||||
racket/match
|
||||
(for-syntax syntax/parse racket/syntax typed/racket/base)
|
||||
;; --- ???
|
||||
syntax/parse
|
||||
syntax/stx
|
||||
trivial/private/common
|
||||
trivial/private/db/schema
|
||||
trivial/private/db/query
|
||||
))
|
||||
|
||||
(require/typed db
|
||||
|
|
@ -48,97 +44,10 @@
|
|||
|
||||
;; =============================================================================
|
||||
|
||||
(define-syntax define-schema: (make-keyword-alias 'define schema-def))
|
||||
(define-syntax let-schema: (make-keyword-alias 'let schema-let))
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
;; -- schema = ((DB-NAME (ROW-TYPE ...))
|
||||
;; ...)
|
||||
|
||||
(define (schema-parser stx)
|
||||
(define x** (cadr (syntax->datum stx)))
|
||||
(cond
|
||||
[(and (list? x**)
|
||||
(for/and ([x* (in-list x**)])
|
||||
(and (= 2 (length x*))
|
||||
(symbol? (car x*))
|
||||
(list? (cadr x*))
|
||||
(for/and ([r (in-list (cadr x*))])
|
||||
(and (pair? r)
|
||||
(symbol? (car r))
|
||||
(symbol? (cdr r)))))))
|
||||
x**]
|
||||
[else #f]))
|
||||
|
||||
(define-values (schema-key schema? schema-def schema-let)
|
||||
(make-value-property 'db:schema schema-parser))
|
||||
(define-syntax-class/predicate schema/expand schema?)
|
||||
|
||||
(define (table-mem schema db)
|
||||
(for/first ([tbl-schema (in-list schema)]
|
||||
#:when (eq? db (car tbl-schema)))
|
||||
(cadr tbl-schema)))
|
||||
|
||||
(define (row-mem tbl-schema row)
|
||||
(for/first ([row-schema (in-list tbl-schema)]
|
||||
#:when (eq? (car row-schema) row))
|
||||
(cdr row-schema)))
|
||||
|
||||
(define (resolve-wildcard tbl-schema row)
|
||||
(cond
|
||||
[(eq? row '*)
|
||||
(map car tbl-schema)]
|
||||
[(list? row)
|
||||
row]
|
||||
[else
|
||||
(list row)]))
|
||||
|
||||
(define (row-ref->type schema qrow)
|
||||
(define q* (string-split qrow "."))
|
||||
(case (length q*)
|
||||
[(1)
|
||||
;; Make sure that row exists SOMEWHERE in table
|
||||
(global-row-mem schema (string->symbol (car q*)))]
|
||||
[(2)
|
||||
;; Have table name + row name, make sure they match
|
||||
(let ([tbl (table-mem schema (string->symbol (car q*)))])
|
||||
(and tbl (row-mem tbl (string->symbol (cadr q*)))))]
|
||||
[else
|
||||
(error 'internal-error "Failed to parse query-row '~a'" qrow)]))
|
||||
|
||||
(define (global-row-mem schema row)
|
||||
(let loop ([acc #f]
|
||||
[schema schema])
|
||||
(cond
|
||||
[(null? schema)
|
||||
acc]
|
||||
[(row-mem (cadr (car schema)) row)
|
||||
=> (lambda (t)
|
||||
(if acc #f (loop t (cdr schema))))]
|
||||
[else
|
||||
(loop acc (cdr schema))])))
|
||||
|
||||
(define (condition*->type* schema condition* #:src stx)
|
||||
(define unsorted
|
||||
(for/fold ([acc '()])
|
||||
([condition (in-list condition*)])
|
||||
(define typ (row-ref->type schema (car condition)))
|
||||
(unless typ
|
||||
(raise-syntax-error 'query-row:
|
||||
"Failed to resolve type for row" (syntax->datum stx) condition))
|
||||
(define val (cdr condition))
|
||||
(define varnum (sql-variable? val))
|
||||
(if varnum
|
||||
(cons (cons typ varnum) acc)
|
||||
acc)))
|
||||
(for/list ([typ+num (sort unsorted string<? #:key cdr)]
|
||||
[num (in-naturals 1)])
|
||||
(unless (= (cdr typ+num) num)
|
||||
(raise-syntax-error 'query-row:
|
||||
(format "Missing query parameter '~a'" num)
|
||||
(syntax->datum stx)))
|
||||
(car typ+num)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define (connection-parser stx)
|
||||
;; Connections have no primitive form -- need to use a wrapped API function
|
||||
#f)
|
||||
|
|
@ -146,67 +55,8 @@
|
|||
(define-values (connection-key connection? connection-def connection-let)
|
||||
(make-value-property 'db:connection connection-parser))
|
||||
(define-syntax-class/predicate connection/expand connection?)
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; -- query
|
||||
|
||||
(define (query-parser stx)
|
||||
(define str (if (string? (syntax-e stx)) (syntax-e stx) (quoted-stx-value? stx)))
|
||||
(and
|
||||
(string? str)
|
||||
(match (with-input-from-string (string-append "(" str ")") read)
|
||||
[(list (? select?) sel (? from?) database rest* ...)
|
||||
(define condition* (condition-parser rest*))
|
||||
(list sel database condition*)]
|
||||
[_ #f])))
|
||||
|
||||
(define (symbol-ci=? s1 s2)
|
||||
(and
|
||||
(symbol? s1)
|
||||
(symbol? s2)
|
||||
(string-ci=? (symbol->string s1) (symbol->string s2))))
|
||||
|
||||
(define-syntax (define-sql-keyword-predicate stx)
|
||||
(syntax-parse stx
|
||||
[(_ kwd*:id ...)
|
||||
#:with (kwd?* ...) (for/list ([kwd (in-list (syntax-e #'(kwd* ...)))])
|
||||
(format-id stx "~a?" (syntax-e kwd)))
|
||||
(syntax/loc stx
|
||||
(begin (define (kwd?* v) (symbol-ci=? v 'kwd*)) ...))]))
|
||||
|
||||
(define-sql-keyword-predicate
|
||||
select
|
||||
from
|
||||
where
|
||||
and)
|
||||
|
||||
;; Check for query parameters. Currently only for Postgres.
|
||||
(define (sql-variable? s)
|
||||
(define str (~a s))
|
||||
(and
|
||||
(= 2 (string-length str))
|
||||
(eq? #\$ (string-ref str 0))
|
||||
(string->number (string (string-ref str 1)))))
|
||||
|
||||
(define (condition-parser v*)
|
||||
(let loop ([v* v*])
|
||||
(match v*
|
||||
['()
|
||||
'()]
|
||||
[(list (or (? where?) (? and?)) db+row '= v rest* ...)
|
||||
(cons (cons (~a db+row) (~a v))
|
||||
(loop rest*))]
|
||||
[(cons _ rest*)
|
||||
(loop rest*)])))
|
||||
|
||||
(define-values (query-key query? query-def query-let)
|
||||
(make-value-property 'db:query query-parser))
|
||||
(define-syntax-class/predicate query/expand query?)
|
||||
|
||||
)
|
||||
|
||||
(define-syntax define-schema: (make-keyword-alias 'define schema-def))
|
||||
(define-syntax let-schema: (make-keyword-alias 'let schema-let))
|
||||
(define-syntax define-connection: (make-keyword-alias 'define connection-def))
|
||||
(define-syntax let-connection: (make-keyword-alias 'let connection-let))
|
||||
|
||||
|
|
@ -220,6 +70,8 @@
|
|||
connection-key
|
||||
#'s.evidence)]))
|
||||
|
||||
;; TODO query-maybe-row
|
||||
|
||||
(define-syntax query-row: (make-alias #'query-row
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ c:connection/expand q:query/expand arg* ...)
|
||||
|
|
@ -229,8 +81,10 @@
|
|||
;; -- Check connection vs. schema
|
||||
(define tbl-schema (table-mem schema table))
|
||||
(unless tbl-schema
|
||||
(raise-syntax-error 'query-row "Unknown table" (syntax->datum stx) table))
|
||||
(raise-syntax-error 'query-row: "Unknown table" (syntax->datum stx) table))
|
||||
(define row* (resolve-wildcard tbl-schema maybe-row*))
|
||||
(when (null? row*)
|
||||
(raise-syntax-error 'query-row: "Empty selection" (syntax->datum stx) 'q.expanded))
|
||||
(define result-type*
|
||||
(for/list ([r (in-list row*)])
|
||||
(or (row-mem tbl-schema r)
|
||||
|
|
@ -254,5 +108,5 @@
|
|||
(vec-stx r-t* ...)))
|
||||
vector-length-key
|
||||
(length result-type*)))]
|
||||
[_ #f]))))
|
||||
[_ #f]))))
|
||||
|
||||
|
|
|
|||
123
private/db/postgres.rkt
Normal file
123
private/db/postgres.rkt
Normal file
|
|
@ -0,0 +1,123 @@
|
|||
#lang racket/base
|
||||
|
||||
;; sql basics, belongs in a new file?
|
||||
|
||||
(provide
|
||||
postgres-parameter?
|
||||
;; (-> Any (Option Natural))
|
||||
;; If input is a Postgres parameter, return the parameter number.
|
||||
;; i.e $2 -> 2
|
||||
;; Otherwise return #f.
|
||||
|
||||
;; -- also exports predicates defined with `define-sql-keyword-predicate`
|
||||
)
|
||||
|
||||
(require
|
||||
(for-syntax
|
||||
typed/racket/base
|
||||
racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
(define-syntax (define-sql-keyword-predicate stx)
|
||||
(syntax-parse stx
|
||||
[(_ kwd*:id ...)
|
||||
#:with (kwd?* ...) (for/list ([kwd (in-list (syntax-e #'(kwd* ...)))])
|
||||
(format-id stx "~a?" (syntax-e kwd)))
|
||||
(syntax/loc stx
|
||||
(begin (begin (provide kwd?*) (define (kwd?* v) (symbol-ci=? v 'kwd*))) ...))]))
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(define (symbol-ci=? s1 s2)
|
||||
(and
|
||||
(symbol? s1)
|
||||
(symbol? s2)
|
||||
(string-ci=? (symbol->string s1) (symbol->string s2))))
|
||||
|
||||
(define-sql-keyword-predicate
|
||||
select
|
||||
from
|
||||
where
|
||||
and)
|
||||
|
||||
;; Check for query parameters. Currently only for Postgres.
|
||||
(define (postgres-parameter? s)
|
||||
(and
|
||||
(or (string? s) (symbol? s))
|
||||
(let ([str (if (string? s) s (symbol->string s))])
|
||||
(and
|
||||
(= 2 (string-length str))
|
||||
(eq? #\$ (string-ref str 0))
|
||||
(string->number (string (string-ref str 1)))))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit rackunit-abbrevs)
|
||||
|
||||
(check-apply* symbol-ci=?
|
||||
['a 'a
|
||||
=> #t]
|
||||
['a 'A
|
||||
=> #t]
|
||||
['yellow 'YeLLOW
|
||||
=> #t]
|
||||
['wait 'forME
|
||||
=> #f]
|
||||
['x 'y
|
||||
=> #f]
|
||||
["A" 'A
|
||||
=> #f]
|
||||
[315 "bage"
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* select?
|
||||
['select
|
||||
=> #t]
|
||||
['SELECT
|
||||
=> #t]
|
||||
['yolo
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* from?
|
||||
['from
|
||||
=> #t]
|
||||
['FROM
|
||||
=> #t]
|
||||
['yolo
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* where?
|
||||
['where
|
||||
=> #t]
|
||||
['WHERE
|
||||
=> #t]
|
||||
['yolo
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* and?
|
||||
['and
|
||||
=> #t]
|
||||
['AND
|
||||
=> #t]
|
||||
['yolo
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* postgres-parameter?
|
||||
["$1"
|
||||
=> 1]
|
||||
['$1
|
||||
=> 1]
|
||||
["$125"
|
||||
=> #f]
|
||||
['$555
|
||||
=> #f]
|
||||
['wepa
|
||||
=> #f]
|
||||
[3
|
||||
=> #f]
|
||||
)
|
||||
)
|
||||
|
|
@ -10,6 +10,7 @@
|
|||
(require
|
||||
trivial/private/common
|
||||
trivial/private/db/schema
|
||||
trivial/private/db/postgres
|
||||
(only-in racket/port with-input-from-string)
|
||||
(only-in racket/format ~a)
|
||||
(only-in racket/string string-replace)
|
||||
|
|
|
|||
|
|
@ -7,17 +7,20 @@
|
|||
|
||||
|
||||
(provide
|
||||
condition*->type*
|
||||
resolve-wildcard
|
||||
row-mem
|
||||
table-mem
|
||||
;; --
|
||||
schema-def
|
||||
schema-let
|
||||
schema/expand
|
||||
)
|
||||
|
||||
(require
|
||||
trivial/private/common
|
||||
trivial/private/db/postgres
|
||||
(only-in racket/string string-split)
|
||||
(for-syntax
|
||||
typed/racket/base
|
||||
racket/syntax
|
||||
syntax/parse)
|
||||
)
|
||||
|
||||
;; =============================================================================
|
||||
|
|
@ -47,37 +50,6 @@
|
|||
(make-value-property 'db:schema schema-parser))
|
||||
(define-syntax-class/predicate schema/expand schema?)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
;; sql basics, belongs in a new file?
|
||||
|
||||
(define (symbol-ci=? s1 s2)
|
||||
(and
|
||||
(symbol? s1)
|
||||
(symbol? s2)
|
||||
(string-ci=? (symbol->string s1) (symbol->string s2))))
|
||||
|
||||
(define-syntax (define-sql-keyword-predicate stx)
|
||||
(syntax-parse stx
|
||||
[(_ kwd*:id ...)
|
||||
#:with (kwd?* ...) (for/list ([kwd (in-list (syntax-e #'(kwd* ...)))])
|
||||
(format-id stx "~a?" (syntax-e kwd)))
|
||||
(syntax/loc stx
|
||||
(begin (define (kwd?* v) (symbol-ci=? v 'kwd*)) ...))]))
|
||||
|
||||
(define-sql-keyword-predicate
|
||||
select
|
||||
from
|
||||
where
|
||||
and)
|
||||
|
||||
;; Check for query parameters. Currently only for Postgres.
|
||||
(define (sql-variable? s)
|
||||
(define str (if (string? s) s (symbol->string s)))
|
||||
(and
|
||||
(= 2 (string-length str))
|
||||
(eq? #\$ (string-ref str 0))
|
||||
(string->number (string (string-ref str 1)))))
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
;(: table-mem (-> DbSchema TableName (Option TableSchema)))
|
||||
|
|
@ -135,7 +107,7 @@
|
|||
(raise-syntax-error 'query-row:
|
||||
"Failed to resolve type for row" (syntax->datum stx) condition))
|
||||
(define val (cdr condition))
|
||||
(define varnum (sql-variable? val))
|
||||
(define varnum (postgres-parameter? val))
|
||||
(if varnum
|
||||
(cons (cons typ varnum) acc)
|
||||
acc)))
|
||||
|
|
@ -164,74 +136,6 @@
|
|||
[#'(quote ((Foo ((Bar . Baz)))))]
|
||||
)
|
||||
|
||||
(check-apply* symbol-ci=?
|
||||
['a 'a
|
||||
=> #t]
|
||||
['a 'A
|
||||
=> #t]
|
||||
['yellow 'YeLLOW
|
||||
=> #t]
|
||||
['wait 'forME
|
||||
=> #f]
|
||||
['x 'y
|
||||
=> #f]
|
||||
["A" 'A
|
||||
=> #f]
|
||||
[315 "bage"
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* select?
|
||||
['select
|
||||
=> #t]
|
||||
['SELECT
|
||||
=> #t]
|
||||
['yolo
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* from?
|
||||
['from
|
||||
=> #t]
|
||||
['FROM
|
||||
=> #t]
|
||||
['yolo
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* where?
|
||||
['where
|
||||
=> #t]
|
||||
['WHERE
|
||||
=> #t]
|
||||
['yolo
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* and?
|
||||
['and
|
||||
=> #t]
|
||||
['AND
|
||||
=> #t]
|
||||
['yolo
|
||||
=> #f]
|
||||
)
|
||||
|
||||
(check-apply* sql-variable?
|
||||
["$1"
|
||||
=> 1]
|
||||
['$1
|
||||
=> 1]
|
||||
["$125"
|
||||
=> #f]
|
||||
['$555
|
||||
=> #f]
|
||||
['wepa
|
||||
=> #f]
|
||||
)
|
||||
(check-exn exn:fail:contract?
|
||||
(lambda () (sql-variable? 3)))
|
||||
|
||||
(check-apply* table-mem
|
||||
['((a ((b . c)))) 'a
|
||||
=> '((b . c))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user