From d7cedf07d9a6b352264bfb84d9394a9aef19cbef Mon Sep 17 00:00:00 2001 From: ben Date: Wed, 9 Mar 2016 16:41:30 -0500 Subject: [PATCH] [db] checkpoint, basic tests working --- private/db.rkt | 258 +++++++++++++++++++++++++++++++++++++++++++++ private/format.rkt | 8 +- test/db-pass.rkt | 33 ++++++ 3 files changed, 293 insertions(+), 6 deletions(-) create mode 100644 private/db.rkt create mode 100644 test/db-pass.rkt diff --git a/private/db.rkt b/private/db.rkt new file mode 100644 index 0000000..c049594 --- /dev/null +++ b/private/db.rkt @@ -0,0 +1,258 @@ +#lang typed/racket/base + +;; TODO do not use this library, it's just for demonstration + +(provide + (all-from-out db) + + ;(rename-out [quasiquote DB]) ;; TODO try using struct types + + define-schema: + define-connection: + postgresql-connect: + + ;query-exec: + query-row: + ;query-maybe-row: + + ;; define schema + ;; start connection + ;; query-exec +) + +;; ----------------------------------------------------------------------------- + +(require + (only-in trivial/private/vector vector-length-key) + (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 +)) + +(require/typed db + (#:opaque Connection connection?) + (postgresql-connect (->* [#:user String #:database String] [] Connection)) + (query-row (-> Connection String Any * (Vectorof Any))) + (query-maybe-row (-> Connection String Any * (Option (Vectorof Any)))) +) + +;; ============================================================================= + +(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) + + (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)) + +;; ----------------------------------------------------------------------------- + +(define-syntax (postgresql-connect: stx) + (syntax-parse stx + [(_ s:schema/expand e* ...) + (syntax-property + (syntax/loc stx (postgresql-connect e* ...)) + connection-key + #'s.evidence)])) + +(define-syntax query-row: (make-alias #'query-row + (lambda (stx) (syntax-parse stx + [(_ c:connection/expand q:query/expand arg* ...) + (define schema (syntax->datum #'c.evidence)) + (define-values (maybe-row* table condition*) + (apply values (syntax->datum #'q.evidence))) + ;; -- 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)) + (define row* (resolve-wildcard tbl-schema maybe-row*)) + (define result-type* + (for/list ([r (in-list row*)]) + (or (row-mem tbl-schema r) + (raise-syntax-error 'query-row "Unknown row" (syntax->datum stx) r)))) + (define type* (condition*->type* schema condition* #:src stx)) + ;; -- Check number of arguments + (let ([num-expected (length type*)] + [num-actual (length (syntax-e #'(arg* ...)))]) + (unless (= num-expected num-actual) + (apply raise-arity-error + 'query-row: + num-expected + (map syntax->datum (syntax-e #'(arg* ...)))))) + (define (id->type id) (format-id stx "~a" id)) + (with-syntax ([(t* ...) (map id->type type*)] + [vec-stx (format-id stx "Vector")] + [(r-t* ...) (map id->type result-type*)]) + (syntax-property + (syntax/loc stx + (cast (query-row c.expanded q.expanded (ann arg* t*) ...) + (vec-stx r-t* ...))) + vector-length-key + (length result-type*)))] + [_ #f])))) + diff --git a/private/format.rkt b/private/format.rkt index 7d16dee..934dda9 100644 --- a/private/format.rkt +++ b/private/format.rkt @@ -59,12 +59,8 @@ (loop (+ i 1) acc)]))] [else #f])) - (define-values ( - _key - fmt? - _define - _let - ) (make-value-property 'string:format format-parser)) + (define-values (_key fmt? _define _let) + (make-value-property 'string:format format-parser)) (define-syntax-class/predicate string/format fmt?) ) diff --git a/test/db-pass.rkt b/test/db-pass.rkt new file mode 100644 index 0000000..9d54087 --- /dev/null +++ b/test/db-pass.rkt @@ -0,0 +1,33 @@ +#lang typed/racket/base + +;(module+ test + (require + trivial/vector + trivial/private/db) + (define-type Id Natural) + (define-schema: M '((word + [(id . Id) + (word . String)]) + (word_syllables + [(word . Id) + (syllables . Id)]))) + (define-connection: c (postgresql-connect: M #:user "ben" #:database "ipoe")) + + (define r0 (query-row: c "SELECT * FROM word LIMIT 1")) + (ann r0 (Vector Id String)) + + (define r1 (query-row: c "SELECT * FROM word WHERE word.word = \"blossom\"")) + (ann r1 (Vector Id String)) + + (define r2 (query-row: c "SELECT * FROM word WHERE word.word = $1" "blossom")) + (ann r2 (Vector Id String)) + + (define-vector: r3 (query-row: c "SELECT id FROM word WHERE word.id = 1")) + (ann r3 (Vector Id)) + + ;(vector-ref: r3 2) + ;(vector-ref: (vector-map: add1 r3) 3) ;; Yes + + ;(query-row: c "SELECT * FROM word WHERE word.word = $1 word.id = $2" "blossom") + ;(query-row: c "SELECT * FROM word WHERE word.word = $1 word.id = $4" "blossom" 2) +