205 lines
6.7 KiB
Racket
205 lines
6.7 KiB
Racket
#lang racket/base
|
|
(require racket/lazy-require
|
|
syntax/parse/private/minimatch
|
|
racket/file
|
|
racket/list)
|
|
(provide dsn-connect
|
|
(struct-out data-source)
|
|
connector?
|
|
arglist?
|
|
writable-datum?
|
|
current-dsn-file
|
|
get-dsn
|
|
put-dsn
|
|
postgresql-data-source
|
|
mysql-data-source
|
|
sqlite3-data-source
|
|
odbc-data-source)
|
|
|
|
(lazy-require
|
|
["../../main.rkt" (postgresql-connect
|
|
mysql-connect
|
|
sqlite3-connect
|
|
odbc-connect)])
|
|
|
|
#|
|
|
DSN v0.1 format
|
|
|
|
A DSN (prefs) file maps symbol => <data-source>
|
|
|
|
<data-source> ::= (db <connector> <args> <extensions>)
|
|
|
|
<connector> ::= postgresql | mysql | sqlite3 | odbc
|
|
|
|
<args> ::= (<arg> ...)
|
|
<arg> ::= <datum> | { <kw> <datum> }
|
|
|
|
<extensions> ::= ((<symbol> <datum>) ...)
|
|
|
|
Extensions associate arbitrary extra information with a data-source (for
|
|
example, SQL dialect information, testing flags, etc). Extension keys
|
|
starting with 'dsn:', 'db:', 'racket:', and 'plt:' are
|
|
reserved. Keys may occur multiple times, but the order should not be
|
|
considered important.
|
|
|
|
db:description ::= <string>, short description
|
|
db:comment ::= <string>, or maybe <xexpr>
|
|
|
|
|#
|
|
|
|
(struct data-source (connector args extensions) #:transparent #:mutable)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define none (gensym 'none))
|
|
|
|
(define (writable-datum? x)
|
|
(or (symbol? x)
|
|
(string? x)
|
|
(number? x)
|
|
(boolean? x)
|
|
(null? x)
|
|
(and (pair? x)
|
|
(writable-datum? (car x))
|
|
(writable-datum? (cdr x)))))
|
|
|
|
(define (connector? x)
|
|
(memq x '(postgresql mysql sqlite3 odbc)))
|
|
|
|
(define (parse-arglist x [default none])
|
|
(define (fail . args)
|
|
(cond [(eq? default none) (apply error 'parse-arglist args)]
|
|
[(procedure? default) (default)]
|
|
[else default]))
|
|
(if (list? x)
|
|
(let loop ([x x] [pargs null] [kwargs null])
|
|
(cond [(null? x)
|
|
(list (reverse pargs)
|
|
(reverse kwargs))]
|
|
[(keyword? (car x))
|
|
(cond [(null? (cdr x)) (fail "keyword without argument: ~a" (car x))]
|
|
[(writable-datum? (cadr x))
|
|
(loop (cddr x) pargs (cons (list (car x) (cadr x)) kwargs))]
|
|
[else
|
|
(fail "expected readable datum: ~e" (cadr x))])]
|
|
[(writable-datum? (car x))
|
|
(loop (cdr x) (cons (car x) pargs) kwargs)]
|
|
[else (fail "expected readable datum: ~e" (car x))]))
|
|
(fail "expected list")))
|
|
|
|
(define (arglist? x)
|
|
(and (parse-arglist x #f) #t))
|
|
|
|
(define (parse-extensions x [default none])
|
|
(let/ec escape
|
|
(define (fail . args)
|
|
(cond [(eq? default none) (apply error 'parse-extensions args)]
|
|
[(procedure? default) (escape (default))]
|
|
[else (escape default)]))
|
|
(if (list? x)
|
|
(map (lambda (x)
|
|
(match x
|
|
[(list (? symbol? key) (? writable-datum? value))
|
|
x]
|
|
[else (fail "expected extension entry: ~e" x)]))
|
|
x)
|
|
(fail "expected list: ~e" x))))
|
|
|
|
(define (extensions? x)
|
|
(and (parse-extensions x #f) #t))
|
|
|
|
(define (sexpr->data-source x)
|
|
(let/ec escape
|
|
(match x
|
|
[(list 'db (? connector? connector) (? arglist? args) (? extensions? exts))
|
|
(data-source connector args exts)]
|
|
[_ #f])))
|
|
|
|
(define (data-source->sexpr x)
|
|
(match x
|
|
[(data-source connector args exts)
|
|
`(db ,connector ,args ,exts)]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define current-dsn-file
|
|
(make-parameter (build-path (find-system-path 'pref-dir) "db-dsn-0.rktd")))
|
|
|
|
(define (get-dsn name [default #f] #:dsn-file [file (current-dsn-file)])
|
|
(let* ([sexpr (get-preference name (lambda () #f) 'timestamp file)])
|
|
(or (and sexpr (sexpr->data-source sexpr))
|
|
(if (procedure? default) (default) default))))
|
|
|
|
(define (put-dsn name value #:dsn-file [file (current-dsn-file)])
|
|
(let* ([sexpr (and value (data-source->sexpr value))])
|
|
(put-preferences (list name)
|
|
(list sexpr)
|
|
(lambda () (error 'put-dsn "DSN file locked"))
|
|
file)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (get-connect x)
|
|
(case x
|
|
((postgresql) postgresql-connect)
|
|
((mysql) mysql-connect)
|
|
((sqlite3) sqlite3-connect)
|
|
((odbc) odbc-connect)))
|
|
|
|
(define dsn-connect
|
|
(make-keyword-procedure
|
|
(lambda (kws kwargs name . pargs)
|
|
(let* ([kws (map list kws kwargs)]
|
|
[file-entry (assq '#:dsn-file kws)]
|
|
[kws* (if file-entry (remq file-entry kws) kws)]
|
|
[file (if file-entry (cdr file-entry) (current-dsn-file))])
|
|
(unless (or (symbol? name) (data-source? name))
|
|
(error 'dsn-connect
|
|
"expected symbol for first argument, got: ~e" name))
|
|
(unless (or (path-string? file) (not file))
|
|
(error 'dsn-connect
|
|
"expected path or string for #:dsn-file keyword, got: ~e"
|
|
file))
|
|
(let ([r (if (data-source? name) name (get-dsn name #f #:dsn-file file))])
|
|
(unless r
|
|
(error 'dsn-connect "cannot find data source named ~e" name))
|
|
(let* ([rargs (parse-arglist (data-source-args r))]
|
|
[rpargs (first rargs)]
|
|
[rkwargs (second rargs)]
|
|
[allpargs (append rpargs pargs)]
|
|
[allkwargs (sort (append rkwargs kws*) keyword<? #:key car)]
|
|
[connect (get-connect (data-source-connector r))])
|
|
(keyword-apply connect (map car allkwargs) (map cadr allkwargs) allpargs)))))))
|
|
|
|
;; ----
|
|
|
|
(define (mk-specialized name connector arity kws)
|
|
(procedure-rename
|
|
(procedure-reduce-keyword-arity
|
|
(make-keyword-procedure
|
|
(lambda (kws kwargs . pargs)
|
|
(data-source connector (apply append pargs (map list kws kwargs)) '())))
|
|
arity '() (sort kws keyword<?))
|
|
name))
|
|
|
|
(define postgresql-data-source
|
|
(mk-specialized 'postgresql-data-source 'postgresql 0
|
|
'(#:user #:database #:password #:server #:port #:socket
|
|
#:allow-cleartext-password? #:ssl
|
|
#:notice-handler #:notification-handler #:debug?)))
|
|
|
|
(define mysql-data-source
|
|
(mk-specialized 'mysql-data-source 'mysql 0
|
|
'(#:user #:database #:password #:server #:port #:socket #:ssl
|
|
#:notice-handler #:debug?)))
|
|
|
|
(define sqlite3-data-source
|
|
(mk-specialized 'sqlite3-data-source 'sqlite3 0
|
|
'(#:database #:mode #:busy-retry-limit #:busy-retry-delay
|
|
#:use-place #:debug?)))
|
|
|
|
(define odbc-data-source
|
|
(mk-specialized 'odbc-data-source 'odbc 0
|
|
'(#:dsn #:user #:password #:notice-handler
|
|
#:strict-parameter-types? #:character-mode #:use-place)))
|