717 lines
29 KiB
Racket
717 lines
29 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/match
|
|
openssl
|
|
openssl/sha1
|
|
unstable/error
|
|
"../generic/interfaces.rkt"
|
|
"../generic/common.rkt"
|
|
"../generic/prepared.rkt"
|
|
"../generic/sql-data.rkt"
|
|
"message.rkt"
|
|
"dbsystem.rkt")
|
|
(provide connection%
|
|
mysql-password-hash)
|
|
|
|
(define MAX-ALLOWED-PACKET (expt 2 30))
|
|
|
|
;; ========================================
|
|
|
|
(define connection%
|
|
(class* statement-cache% (connection<%>)
|
|
(init-private notice-handler)
|
|
(define inport #f)
|
|
(define outport #f)
|
|
|
|
(inherit call-with-lock
|
|
call-with-lock*
|
|
add-delayed-call!
|
|
check-valid-tx-status
|
|
get-tx-status
|
|
set-tx-status!
|
|
check-statement/tx
|
|
dprintf
|
|
prepare1
|
|
check/invalidate-cache)
|
|
|
|
(super-new)
|
|
|
|
;; ========================================
|
|
|
|
;; == Communication
|
|
|
|
#|
|
|
During initial setup, okay to send and recv directly, since reference
|
|
to connection does not escape to user. In particular, no danger of trying
|
|
to start a new exchange on top of an incomplete failed one.
|
|
|
|
After initial setup, communication can only happen within lock, and any
|
|
error (other than exn:fail:sql) that occurs between sending the message
|
|
buffer (flush-message-buffer) and receiving the last message (recv)
|
|
must cause the connection to disconnect. Such errors include communication
|
|
errors and breaks.
|
|
|#
|
|
|
|
(define msg-buffer null)
|
|
(define next-msg-num 0)
|
|
|
|
(define/private (fresh-exchange)
|
|
(set! next-msg-num 0))
|
|
|
|
;; buffer-message : message -> void
|
|
(define/private (buffer-message msg)
|
|
(dprintf " >> ~s\n" msg)
|
|
(set! msg-buffer (cons (cons msg next-msg-num) msg-buffer))
|
|
(set! next-msg-num (add1 next-msg-num)))
|
|
|
|
;; flush-message-buffer : -> void
|
|
(define/private (flush-message-buffer)
|
|
(for ([msg+num (in-list (reverse msg-buffer))])
|
|
(write-packet outport (car msg+num) (cdr msg+num)))
|
|
(set! msg-buffer null)
|
|
(flush-output outport))
|
|
|
|
;; send-message : message -> void
|
|
(define/private (send-message msg)
|
|
(buffer-message msg)
|
|
(flush-message-buffer))
|
|
|
|
(define/private (call-with-sync fsym proc)
|
|
(with-handlers ([(lambda (e) #t)
|
|
(lambda (e)
|
|
;; Anything but exn:fail:sql (raised by recv-message) indicates
|
|
;; a communication error.
|
|
(unless (exn:fail:sql? e)
|
|
(disconnect* #f))
|
|
(raise e))])
|
|
(flush-message-buffer)
|
|
(proc)))
|
|
|
|
;; recv : symbol/#f [(list-of symbol)] -> message
|
|
;; Automatically handles asynchronous messages
|
|
(define/private (recv fsym expectation [field-dvecs #f])
|
|
(define r (recv* fsym expectation field-dvecs))
|
|
(when (error-packet? r)
|
|
(raise-backend-error fsym r))
|
|
r)
|
|
|
|
(define/private (recv* fsym expectation field-dvecs)
|
|
(define (advance . ss)
|
|
(unless (or (not expectation)
|
|
(null? ss)
|
|
(memq expectation ss))
|
|
(error/comm fsym)))
|
|
(define (err packet)
|
|
(error/comm fsym))
|
|
(let-values ([(msg-num next) (parse-packet inport expectation field-dvecs)])
|
|
(set! next-msg-num (add1 msg-num))
|
|
(dprintf " << ~s\n" next)
|
|
;; Update transaction status (see Transactions below)
|
|
(when (ok-packet? next)
|
|
(set-tx-status! fsym (bitwise-bit-set? (ok-packet-server-status next) 0)))
|
|
(when (eof-packet? next)
|
|
(set-tx-status! fsym (bitwise-bit-set? (eof-packet-server-status next) 0)))
|
|
(when (error-packet? next)
|
|
(when (member (error-packet-errno next) '(1213 1205))
|
|
(when (get-tx-status)
|
|
(set-tx-status! fsym 'invalid))))
|
|
(match next
|
|
[(? handshake-packet?)
|
|
(advance 'handshake)]
|
|
[(? ok-packet?)
|
|
(advance)]
|
|
[(? change-plugin-packet?)
|
|
(advance 'auth)]
|
|
[(? error-packet?)
|
|
(advance)]
|
|
[(? result-set-header-packet?)
|
|
(advance 'result)]
|
|
[(? field-packet?)
|
|
(advance 'field)]
|
|
[(? row-data-packet?)
|
|
(advance 'data)]
|
|
[(? binary-row-data-packet?)
|
|
(advance 'binary-data)]
|
|
[(? ok-prepared-statement-packet?)
|
|
(advance 'prep-ok)]
|
|
[(? eof-packet?)
|
|
(advance 'field 'data 'binary-data)]
|
|
[(struct unknown-packet (expected contents))
|
|
(error/comm fsym expected)]
|
|
[else
|
|
(err next)])
|
|
next))
|
|
|
|
;; ========================================
|
|
|
|
;; Connection management
|
|
|
|
(define/override (disconnect* politely?)
|
|
(super disconnect* politely?)
|
|
(let ([outport* outport]
|
|
[inport* inport])
|
|
(when outport*
|
|
(when politely?
|
|
(fresh-exchange)
|
|
(send-message (make-command-packet 'quit "")))
|
|
(with-handlers ([exn:fail? void]) (close-output-port outport*))
|
|
(set! outport #f))
|
|
(when inport*
|
|
(with-handlers ([exn:fail? void]) (close-input-port inport*))
|
|
(set! inport #f))))
|
|
|
|
;; connected? : -> boolean
|
|
(define/override (connected?)
|
|
(let ([outport outport])
|
|
(and outport (not (port-closed? outport)))))
|
|
|
|
(define/public (get-dbsystem)
|
|
dbsystem)
|
|
|
|
;; ========================================
|
|
|
|
;; == Connect
|
|
|
|
;; attach-to-ports : input-port output-port -> void
|
|
(define/public (attach-to-ports in out)
|
|
(set! inport in)
|
|
(set! outport out))
|
|
|
|
;; start-connection-protocol : string/#f string string/#f -> void
|
|
(define/public (start-connection-protocol dbname username password ssl ssl-context)
|
|
(fresh-exchange)
|
|
(let ([r (recv 'mysql-connect 'handshake)])
|
|
(match r
|
|
[(struct handshake-packet (pver sver tid scramble capabilities charset status auth))
|
|
(check-required-flags capabilities)
|
|
(unless (member auth '("mysql_native_password" #f))
|
|
(raise-misc-error 'mysql-connect "back end requested unsupported authentication plugin"
|
|
'("plugin" value) auth))
|
|
(define do-ssl?
|
|
(and (case ssl ((yes optional) #t) ((no) #f))
|
|
(memq 'ssl capabilities)))
|
|
(when (and (eq? ssl 'yes) (not do-ssl?))
|
|
(error 'mysql-connect "back end refused SSL connection"))
|
|
(define wanted-capabilities (desired-capabilities capabilities do-ssl? dbname))
|
|
(when do-ssl?
|
|
(send-message (make-abbrev-client-auth-packet wanted-capabilities))
|
|
(let-values ([(sin sout)
|
|
(ports->ssl-ports inport outport
|
|
#:mode 'connect
|
|
#:context ssl-context
|
|
#:close-original? #t)])
|
|
(attach-to-ports sin sout)))
|
|
(authenticate wanted-capabilities username password dbname
|
|
(or auth "mysql_native_password") scramble)]
|
|
[_ (error/comm 'mysql-connect "during authentication")])))
|
|
|
|
(define/private (authenticate capabilities username password dbname auth-plugin scramble)
|
|
(let loop ([auth-plugin auth-plugin] [scramble scramble] [first? #t])
|
|
(define (auth data)
|
|
(if first?
|
|
(make-client-auth-packet capabilities MAX-ALLOWED-PACKET 'utf8-general-ci
|
|
username data dbname auth-plugin)
|
|
(make-auth-followup-packet data)))
|
|
(cond [(equal? auth-plugin "mysql_native_password")
|
|
(send-message (auth (scramble-password scramble password)))]
|
|
[(equal? auth-plugin "mysql_old_password")
|
|
(send-message (auth (bytes-append (old-scramble-password scramble password)
|
|
(bytes 0))))]
|
|
[else (raise-misc-error 'mysql-connect "back end does not support authentication plugin"
|
|
'("plugin" value) auth-plugin)])
|
|
(match (recv 'mysql-connect 'auth)
|
|
[(struct ok-packet (_ _ status warnings message))
|
|
(after-connect)]
|
|
[(struct change-plugin-packet (plugin data))
|
|
;; if plugin = #f, means "mysql_old_password"
|
|
(loop (or plugin "mysql_old_password") (or data scramble) #f)])))
|
|
|
|
(define/private (check-required-flags capabilities)
|
|
(for-each (lambda (rf)
|
|
(unless (memq rf capabilities)
|
|
(raise-misc-error 'mysql-connect "server does not support required capability"
|
|
"capability" rf)))
|
|
REQUIRED-CAPABILITIES))
|
|
|
|
(define/private (desired-capabilities capabilities ssl? dbname)
|
|
(append (if ssl? '(ssl) '())
|
|
(if dbname '(connect-with-db) '())
|
|
'(interactive)
|
|
(filter (lambda (c) (memq c DESIRED-CAPABILITIES)) capabilities)))
|
|
|
|
;; Set connection to use utf8 encoding
|
|
(define/private (after-connect)
|
|
(query 'mysql-connect "set names 'utf8'" #f)
|
|
(void))
|
|
|
|
;; ========================================
|
|
|
|
;; == Query
|
|
|
|
;; query : symbol Statement boolean -> QueryResult
|
|
(define/public (query fsym stmt cursor?)
|
|
(let ([result
|
|
(call-with-lock fsym
|
|
(lambda ()
|
|
(check-valid-tx-status fsym)
|
|
(let* ([stmt (check-statement fsym stmt cursor?)]
|
|
[stmt-type
|
|
(cond [(statement-binding? stmt)
|
|
(send (statement-binding-pst stmt) get-stmt-type)]
|
|
[(string? stmt)
|
|
(classify-my-sql stmt)])])
|
|
(check-statement/tx fsym stmt-type)
|
|
(begin0 (query1 fsym stmt cursor? #t)
|
|
(statement:after-exec stmt #f)))))])
|
|
(query1:process-result fsym result)))
|
|
|
|
;; query1 : symbol Statement -> QueryResult
|
|
(define/private (query1 fsym stmt cursor? warnings?)
|
|
(let ([delenda (check/invalidate-cache stmt)])
|
|
(when delenda
|
|
(for ([(_sql pst) (in-hash delenda)])
|
|
(free-statement pst #f))))
|
|
(let ([wbox (and warnings? (box 0))])
|
|
(fresh-exchange)
|
|
(query1:enqueue stmt cursor?)
|
|
(begin0 (call-with-sync fsym
|
|
(lambda () (query1:collect fsym stmt (not (string? stmt)) cursor? wbox)))
|
|
(when (and warnings? (not (zero? (unbox wbox))))
|
|
(fetch-warnings fsym)))))
|
|
|
|
;; check-statement : symbol any boolean -> statement-binding
|
|
;; For cursor, need to clone pstmt, because only one cursor can be
|
|
;; open for a statement at a time. (Could delay clone until
|
|
;; needed, but that seems more complicated.)
|
|
(define/private (check-statement fsym stmt cursor?)
|
|
(cond [(statement-binding? stmt)
|
|
(let ([pst (statement-binding-pst stmt)])
|
|
(send pst check-owner fsym this stmt)
|
|
(for ([typeid (in-list (send pst get-result-typeids))])
|
|
(unless (supported-result-typeid? typeid)
|
|
(error/unsupported-type fsym typeid)))
|
|
(cond [cursor?
|
|
(let ([pst* (prepare1 fsym (send pst get-stmt) #f)])
|
|
(statement-binding pst* (statement-binding-params stmt)))]
|
|
[else stmt]))]
|
|
[(and (string? stmt) (force-prepare-sql? fsym stmt))
|
|
(let ([pst (prepare1 fsym stmt (not cursor?))])
|
|
(check-statement fsym (send pst bind fsym null) #f))]
|
|
[else stmt]))
|
|
|
|
;; query1:enqueue : statement -> void
|
|
(define/private (query1:enqueue stmt cursor?)
|
|
(cond [(statement-binding? stmt)
|
|
(let* ([pst (statement-binding-pst stmt)]
|
|
[id (send pst get-handle)]
|
|
[params (statement-binding-params stmt)]
|
|
[param-count (length params)]
|
|
[null-map (map sql-null? params)]
|
|
[flags (if cursor? '(cursor/read-only) '())])
|
|
;; Assume max_packet_length = 16M = 2^24,
|
|
;; overhead of 20 bytes for other packet fields.
|
|
;; Oversimplified param size estimate:
|
|
;; - 20 bytes per param (fixed size <= 20, string length code <= 20)
|
|
;; - bytes-length for bytes, 4*string-length for strings
|
|
;; Use long data for any param that takes more than its "fair share".
|
|
(define (param-size p)
|
|
(cond [(string? p) (* 4 (string-length p))]
|
|
[(bytes? p) (bytes-length p)]
|
|
[else 0]))
|
|
(let* ([space (- (expt 2 24) 20 (* 20 param-count))]
|
|
[var-param-size (for/sum ([p (in-list params)]) (param-size p))])
|
|
(cond [(and (< var-param-size space))
|
|
(buffer-message (make-execute-packet id flags null-map params))]
|
|
[else
|
|
(let* ([var-param-count
|
|
(for/sum ([p (in-list params)]
|
|
#:when (or (string? p) (bytes? p)))
|
|
1)]
|
|
[fair-share (floor (/ space (max 1 var-param-count)))]
|
|
[param+evict-list
|
|
(for/list ([p (in-list params)])
|
|
(cons p (> (param-size p) fair-share)))]
|
|
[short-params
|
|
(for/list ([p+e (in-list param+evict-list)])
|
|
(let ([p (car p+e)])
|
|
(if (cdr p+e)
|
|
(if (string? p) 'long-string 'long-binary)
|
|
p)))])
|
|
(for ([p+e (in-list param+evict-list)]
|
|
[param-id (in-naturals)]
|
|
#:when (cdr p+e))
|
|
(let* ([p (car p+e)]
|
|
[pb (if (string? p) (string->bytes/utf-8 p) p)]
|
|
[pblen (bytes-length pb)]
|
|
[CHUNK #e1e6])
|
|
(let chunkloop ([sent 0])
|
|
(when (< sent pblen)
|
|
(let ([next (min pblen (+ sent CHUNK))])
|
|
(buffer-message
|
|
(make-long-data-packet id param-id (subbytes pb sent next)))
|
|
(fresh-exchange)
|
|
(chunkloop next))))))
|
|
(buffer-message (make-execute-packet id flags null-map short-params)))])))]
|
|
[else ;; string
|
|
(buffer-message (make-command-packet 'query stmt))]))
|
|
|
|
;; query1:collect : symbol bool -> QueryResult stream
|
|
(define/private (query1:collect fsym stmt binary? cursor? wbox)
|
|
(let ([r (recv fsym 'result)])
|
|
(match r
|
|
[(struct ok-packet (affected-rows insert-id status warnings message))
|
|
(when wbox (set-box! wbox warnings))
|
|
(vector 'command `((affected-rows . ,affected-rows)
|
|
(insert-id . ,(if (zero? insert-id) #f insert-id))
|
|
(status . ,status)
|
|
(message . ,message)))]
|
|
[(struct result-set-header-packet (fields extra))
|
|
(let* ([field-dvecs (query1:get-fields fsym binary?)])
|
|
(if cursor?
|
|
(vector 'cursor field-dvecs (statement-binding-pst stmt))
|
|
(vector 'rows
|
|
field-dvecs
|
|
(query1:get-rows fsym field-dvecs binary? wbox #f))))])))
|
|
|
|
(define/private (query1:get-fields fsym binary?)
|
|
(let ([r (recv fsym 'field)])
|
|
(match r
|
|
[(? field-packet?)
|
|
(cons (parse-field-dvec r) (query1:get-fields fsym binary?))]
|
|
[(struct eof-packet (warning status))
|
|
null])))
|
|
|
|
(define/private (query1:get-rows fsym field-dvecs binary? wbox end-box)
|
|
;; Note: binary? should always be #t, unless force-prepare-sql? misses something.
|
|
(let ([r (recv fsym (if binary? 'binary-data 'data) field-dvecs)])
|
|
(match r
|
|
[(struct row-data-packet (data))
|
|
(cons data (query1:get-rows fsym field-dvecs binary? wbox end-box))]
|
|
[(struct binary-row-data-packet (data))
|
|
(cons data (query1:get-rows fsym field-dvecs binary? wbox end-box))]
|
|
[(struct eof-packet (warnings status))
|
|
(when wbox (set-box! wbox warnings))
|
|
(when (and end-box (bitwise-bit-set? status 7)) ;; 'last-row-sent
|
|
(set-box! end-box #t))
|
|
null])))
|
|
|
|
(define/private (query1:process-result fsym result)
|
|
(match result
|
|
[(vector 'rows field-dvecs rows)
|
|
(rows-result (map field-dvec->field-info field-dvecs) rows)]
|
|
[(vector 'command command-info)
|
|
(simple-result command-info)]
|
|
[(vector 'cursor field-dvecs pst)
|
|
(cursor-result (map field-dvec->field-info field-dvecs)
|
|
pst
|
|
(list field-dvecs (box #f)))]))
|
|
|
|
;; == Cursor
|
|
|
|
(define/public (fetch/cursor fsym cursor fetch-size)
|
|
(let ([pst (cursor-result-pst cursor)]
|
|
[extra (cursor-result-extra cursor)])
|
|
(send pst check-owner fsym this pst)
|
|
(let ([field-dvecs (car extra)]
|
|
[end-box (cadr extra)])
|
|
(call-with-lock fsym
|
|
(lambda ()
|
|
(cond [(unbox end-box)
|
|
#f]
|
|
[else
|
|
(let ([wbox (box 0)])
|
|
(fresh-exchange)
|
|
(buffer-message (make-fetch-packet (send pst get-handle) fetch-size))
|
|
(begin0 (call-with-sync fsym
|
|
(lambda () (query1:get-rows fsym field-dvecs #t wbox end-box)))
|
|
(when (not (zero? (unbox wbox)))
|
|
(fetch-warnings fsym))))]))))))
|
|
|
|
;; == Prepare
|
|
|
|
(define/override (classify-stmt sql) (classify-my-sql sql))
|
|
|
|
(define/override (prepare1* fsym stmt close-on-exec? stmt-type)
|
|
(fresh-exchange)
|
|
(buffer-message (make-command-packet 'statement-prepare stmt))
|
|
(call-with-sync fsym
|
|
(lambda ()
|
|
(let ([r (recv fsym 'prep-ok)])
|
|
(match r
|
|
[(struct ok-prepared-statement-packet (id fields params))
|
|
(let ([param-dvecs
|
|
(if (zero? params) null (prepare1:get-field-descriptions fsym))]
|
|
[field-dvecs
|
|
(if (zero? fields) null (prepare1:get-field-descriptions fsym))])
|
|
(new prepared-statement%
|
|
(handle id)
|
|
(close-on-exec? close-on-exec?)
|
|
(param-typeids (map field-dvec->typeid param-dvecs))
|
|
(result-dvecs field-dvecs)
|
|
(stmt stmt)
|
|
(stmt-type stmt-type)
|
|
(owner this)))])))))
|
|
|
|
(define/private (prepare1:get-field-descriptions fsym)
|
|
(let ([r (recv fsym 'field)])
|
|
(match r
|
|
[(struct eof-packet (warning-count status))
|
|
null]
|
|
[(? field-packet?)
|
|
(cons (parse-field-dvec r) (prepare1:get-field-descriptions fsym))])))
|
|
|
|
(define/public (get-base) this)
|
|
|
|
(define/public (free-statement pst need-lock?)
|
|
;; Important: *buffer* statement-close message, but do not send (ie, flush).
|
|
;; That way, message included in same TCP packet as next query message, avoiding
|
|
;; write-write-read TCP packet sequence, Nagle's algorithm & delayed ACK issue.
|
|
(define (do-free-statement)
|
|
(let ([id (send pst get-handle)])
|
|
(when (and id outport) ;; outport = connected?
|
|
(send pst set-handle #f)
|
|
(fresh-exchange)
|
|
(buffer-message (make-command:statement-packet 'statement-close id)))))
|
|
(if need-lock?
|
|
(call-with-lock* 'free-statement do-free-statement void #f)
|
|
(do-free-statement)))
|
|
|
|
;; == Warnings
|
|
|
|
(define/private (fetch-warnings fsym)
|
|
(unless (eq? notice-handler void)
|
|
(let ([result (query1 fsym "SHOW WARNINGS" #f #f)])
|
|
(define (find-index name dvecs)
|
|
(for/or ([dvec (in-list dvecs)]
|
|
[i (in-naturals)])
|
|
(and (equal? (field-dvec->name dvec) name) i)))
|
|
(match result
|
|
[(vector 'rows field-dvecs rows)
|
|
(let ([code-index (find-index "Code" field-dvecs)]
|
|
[message-index (find-index "Message" field-dvecs)])
|
|
(for ([row (in-list rows)])
|
|
(let ([code (string->number (vector-ref row code-index))]
|
|
[message (vector-ref row message-index)])
|
|
(add-delayed-call! (lambda () (notice-handler code message))))))]))))
|
|
|
|
;; == Transactions
|
|
|
|
;; MySQL: what causes implicit commit, when is transaction rolled back
|
|
;; http://dev.mysql.com/doc/refman/5.1/en/implicit-commit.html
|
|
;; http://dev.mysql.com/doc/refman/5.1/en/innodb-error-handling.html
|
|
;; http://dev.mysql.com/doc/refman/5.1/en/innodb-error-codes.html
|
|
;;
|
|
;; Sounds like MySQL rolls back transaction (but may keep open!) on
|
|
;; - transaction deadlock = 1213 (ER_LOCK_DEADLOCK)
|
|
;; - lock wait timeout (depends on config) = 1205 (ER_LOCK_WAIT_TIMEOUT)
|
|
|
|
(define/override (start-transaction* fsym isolation option)
|
|
(cond [(eq? isolation 'nested)
|
|
(let ([savepoint (generate-name)])
|
|
(query1 fsym (format "SAVEPOINT ~a" savepoint) #f #t)
|
|
savepoint)]
|
|
[else
|
|
(let ([isolation-level (isolation-symbol->string isolation)])
|
|
(when option
|
|
;; No options supported
|
|
(raise-argument-error fsym "#f" option))
|
|
(when isolation-level
|
|
(query1 fsym (format "SET TRANSACTION ISOLATION LEVEL ~a" isolation-level) #f #t))
|
|
(query1 fsym "START TRANSACTION" #f #t)
|
|
#f)]))
|
|
|
|
(define/override (end-transaction* fsym mode savepoint)
|
|
(case mode
|
|
((commit)
|
|
(cond [savepoint
|
|
(query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #f #t)]
|
|
[else
|
|
(query1 fsym "COMMIT" #f #t)]))
|
|
((rollback)
|
|
(cond [savepoint
|
|
(query1 fsym (format "ROLLBACK TO SAVEPOINT ~a" savepoint) #f #t)
|
|
(query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #f #t)]
|
|
[else
|
|
(query1 fsym "ROLLBACK" #f #t)])))
|
|
(void))
|
|
|
|
;; name-counter : number
|
|
(define name-counter 0)
|
|
|
|
;; generate-name : -> string
|
|
(define/private (generate-name)
|
|
(let ([n name-counter])
|
|
(set! name-counter (add1 name-counter))
|
|
(format "λmz_~a" n)))
|
|
|
|
;; Reflection
|
|
|
|
(define/public (list-tables fsym schema)
|
|
(let* ([stmt
|
|
;; schema is ignored; search = current
|
|
(string-append "SELECT table_name FROM information_schema.tables "
|
|
"WHERE table_schema = schema()")]
|
|
[rows
|
|
(vector-ref (call-with-lock fsym (lambda () (query1 fsym stmt #f #t))) 2)])
|
|
(for/list ([row (in-list rows)])
|
|
(vector-ref row 0))))
|
|
|
|
))
|
|
|
|
;; ========================================
|
|
|
|
;; mysql-password-hash : string -> string
|
|
(define (mysql-password-hash password)
|
|
(bytes->hex-string (password-hash password)))
|
|
|
|
;; scramble-password : bytes string -> bytes
|
|
(define (scramble-password scramble password)
|
|
(and scramble password
|
|
(let* ([stage1 (cond [(string? password) (password-hash password)]
|
|
[(pair? password) (hex-string->bytes (cadr password))])]
|
|
[stage2 (sha1-bytes (open-input-bytes stage1))]
|
|
[stage3 (sha1-bytes (open-input-bytes (bytes-append scramble stage2)))]
|
|
[reply (bytes-xor stage1 stage3)])
|
|
reply)))
|
|
|
|
;; password-hash : string -> bytes
|
|
(define (password-hash password)
|
|
(let* ([password (string->bytes/latin-1 password)]
|
|
[stage1 (sha1-bytes (open-input-bytes password))])
|
|
stage1))
|
|
|
|
;; bytes-xor : bytes bytes -> bytes
|
|
;; Assumes args are same length
|
|
(define (bytes-xor a b)
|
|
(let ([c (make-bytes (bytes-length a))])
|
|
(let loop ([i 0])
|
|
(when (< i (bytes-length c))
|
|
(bytes-set! c i
|
|
(bitwise-xor (bytes-ref a i) (bytes-ref b i)))
|
|
(loop (add1 i))))
|
|
c))
|
|
|
|
(define (hex-string->bytes s)
|
|
(define (hex-digit->int c)
|
|
(let ([c (char->integer c)])
|
|
(cond [(<= (char->integer #\0) c (char->integer #\9))
|
|
(- c (char->integer #\0))]
|
|
[(<= (char->integer #\a) c (char->integer #\f))
|
|
(+ 10 (- c (char->integer #\a)))]
|
|
[(<= (char->integer #\A) c (char->integer #\F))
|
|
(+ 10 (- c (char->integer #\A)))])))
|
|
(unless (and (string? s) (even? (string-length s))
|
|
(regexp-match? #rx"[0-9a-zA-Z]*" s))
|
|
(raise-type-error 'hex-string->bytes
|
|
"string containing an even number of hexadecimal digits" s))
|
|
(let* ([c (quotient (string-length s) 2)]
|
|
[b (make-bytes c)])
|
|
(for ([i (in-range c)])
|
|
(let ([high (hex-digit->int (string-ref s (+ i i)))]
|
|
[low (hex-digit->int (string-ref s (+ i i 1)))])
|
|
(bytes-set! b i (+ (arithmetic-shift high 4) low))))
|
|
b))
|
|
|
|
;; =======================================
|
|
|
|
(provide old-scramble-password
|
|
hash323
|
|
hash323->string)
|
|
|
|
(define (old-scramble-password scramble password)
|
|
(define (xor a b) (bitwise-xor a b))
|
|
(define RMAX #x3FFFFFFF)
|
|
(and scramble password
|
|
(let* ([scramble (subbytes scramble 0 8)]
|
|
[password (string->bytes/utf-8 password)]
|
|
[hp (hash323 password)]
|
|
[hm (hash323 scramble)]
|
|
[r1 (modulo (xor (car hp) (car hm)) RMAX)]
|
|
[r2 (modulo (xor (cdr hp) (cdr hm)) RMAX)]
|
|
[out (make-bytes 8 0)])
|
|
(define (rnd)
|
|
(set! r1 (modulo (+ (* 3 r1) r2) RMAX))
|
|
(set! r2 (modulo (+ r1 r2 33) RMAX))
|
|
(/ (exact->inexact r1) (exact->inexact RMAX)))
|
|
(for ([i (in-range (bytes-length scramble))])
|
|
(let ([b (+ (inexact->exact (floor (* (rnd) 31))) 64)])
|
|
(bytes-set! out i b)
|
|
(values r1 r2)))
|
|
(let ([extra (inexact->exact (floor (* (rnd) 31)))])
|
|
(for ([i (in-range (bytes-length scramble))])
|
|
(bytes-set! out i (xor (bytes-ref out i) extra))))
|
|
out)))
|
|
|
|
(define (hash323 bs)
|
|
(define (xor a b) (bitwise-xor a b))
|
|
(define-syntax-rule (normalize! var)
|
|
(set! var (bitwise-and var (sub1 (arithmetic-shift 1 64)))))
|
|
(let ([nr 1345345333]
|
|
[add 7]
|
|
[nr2 #x12345671])
|
|
(for ([i (in-range (bytes-length bs))]
|
|
#:when (not (memv (bytes-ref bs i) '(#\space #\tab))))
|
|
(let ([tmp (bytes-ref bs i)])
|
|
(set! nr (xor nr
|
|
(+ (* (+ (bitwise-and nr 63) add) tmp)
|
|
(arithmetic-shift nr 8))))
|
|
(normalize! nr)
|
|
(set! nr2 (+ nr2
|
|
(xor (arithmetic-shift nr2 8) nr)))
|
|
(normalize! nr2)
|
|
(set! add (+ add tmp))
|
|
(normalize! add)))
|
|
(cons (bitwise-and nr (sub1 (arithmetic-shift 1 31)))
|
|
(bitwise-and nr2 (sub1 (arithmetic-shift 1 31))))))
|
|
|
|
(define (hash323->string bs)
|
|
(let ([p (hash323 bs)])
|
|
(bytes-append (integer->integer-bytes (car p) 4 #f #f)
|
|
(integer->integer-bytes (cdr p) 4 #f #f))))
|
|
|
|
;; ========================================
|
|
|
|
(define REQUIRED-CAPABILITIES
|
|
'(long-flag
|
|
connect-with-db
|
|
protocol-41
|
|
secure-connection))
|
|
|
|
(define DESIRED-CAPABILITIES
|
|
'(long-password
|
|
long-flag
|
|
transactions
|
|
protocol-41
|
|
secure-connection
|
|
plugin-auth))
|
|
|
|
;; raise-backend-error : symbol ErrorPacket -> raises exn
|
|
(define (raise-backend-error who r)
|
|
(define code (error-packet-sqlstate r))
|
|
(define message (error-packet-message r))
|
|
(define props (list (cons 'errno (error-packet-errno r))
|
|
(cons 'code code)
|
|
(cons 'message message)))
|
|
(raise-sql-error who code message props))
|
|
|
|
;; ========================================
|
|
|
|
#|
|
|
MySQL allows only certain kinds of statements to be prepared; the rest
|
|
must go through the old execution path. See here:
|
|
http://dev.mysql.com/doc/refman/5.0/en/c-api-prepared-statements.html
|
|
According to that page, the following statements may be prepared:
|
|
|
|
CALL, CREATE TABLE, DELETE, DO, INSERT, REPLACE, SELECT, SET, UPDATE,
|
|
and most SHOW statements
|
|
|
|
On the other hand, we want to force all rows-returning statements
|
|
through the prepared-statement path to use the binary data
|
|
protocol. That would seem to be the following:
|
|
|
|
SELECT and SHOW
|
|
|#
|
|
|
|
(define (force-prepare-sql? fsym stmt)
|
|
(memq (classify-my-sql stmt) '(select show)))
|