diff --git a/private/db.rkt b/private/db.rkt index c049594..f5ebd4e 100644 --- a/private/db.rkt +++ b/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 stringdatum 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])))) diff --git a/private/db/postgres.rkt b/private/db/postgres.rkt new file mode 100644 index 0000000..d5b9c3f --- /dev/null +++ b/private/db/postgres.rkt @@ -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] + ) +) diff --git a/private/db/query.rkt b/private/db/query.rkt index b9e9288..305d623 100644 --- a/private/db/query.rkt +++ b/private/db/query.rkt @@ -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) diff --git a/private/db/schema.rkt b/private/db/schema.rkt index 25d61ce..e7289f0 100644 --- a/private/db/schema.rkt +++ b/private/db/schema.rkt @@ -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))]