pax_global_header00006660000000000000000000000064131244132050014505gustar00rootroot0000000000000052 comment=5f91df6e59c4798e3a196dc4b488fbdc5b331680 qmynd-20170630-git/000077500000000000000000000000001312441320500136625ustar00rootroot00000000000000qmynd-20170630-git/LICENSE000066400000000000000000000020451312441320500146700ustar00rootroot00000000000000Copyright (c) 2012-2013 Google, Inc. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. qmynd-20170630-git/TODO000066400000000000000000000011261312441320500143520ustar00rootroot00000000000000Features: • Pluggable Authentication • Connect timeout • Deal with LOCAL_INFILE requests • Multi-ResultSets Cleanup: • Add conditions. • Replace ASSERT with conditions. • Drop “mysql-” prefix from everything: this is a MySQL driver, so it's redundant. • Replace qtest by 5am or stefil, etc. • where appropriate, use -octets instead of -string and -raw instead of -as-text Convenience: • Convenience functions for toggling bits in status and capability. Query Results: • Row at a time result processing Good Citizenship: • export AF_LOCAL functionality to usocket qmynd-20170630-git/qmynd.asd000066400000000000000000000103131312441320500155010ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defsystem :qmynd :name "MySQL Native Driver" :author "Alejandro Sedeño" :version "1.0" :licence "MIT-style" :maintainer '("Alejandro Sedeño") :description "MySQL Native Driver" :long-description "MySQL Native Driver for Common Lisp" :depends-on (:babel :flexi-streams :ironclad :list-of :trivial-gray-streams :usocket #-asdf3 :uiop) :weakly-depends-on (:cl+ssl :chipz :salza2) :around-compile "asdf-finalizers:check-finalizers-around-compile" :serial nil :components ((:module "src" :serial nil :components ((:file "pkgdcl") (:module "common" :serial nil :depends-on ("pkgdcl") :components ((:file "charsets") (:file "constants" :depends-on ("charsets")) (:file "conditions") (:file "feature-detection") (:file "utilities") (:file "date-time" :depends-on ("constants" "utilities")) (:file "misc" :depends-on ("constants")))) (:module "wire-protocol" :serial nil :depends-on ("common") :components ((:file "wire-packet") (:file "basic-types" :depends-on ("wire-packet")) (:file "compressed-protocol" :depends-on ("basic-types")))) (module "mysql-protocol" :serial nil :depends-on ("common" "wire-protocol") :components ((:file "define-packet") (:file "connection") (:file "response-packets" :depends-on ("define-packet" "connection")) (:file "authentication") (:file "handshake" :depends-on ("define-packet" "connection" "authentication")) (:file "response-result-set" :depends-on ("define-packet")) (:module "text-protocol" :serial nil :depends-on ("connection" "define-packet" "response-result-set") :components ((:file "command-quit") (:file "command-initialize-database") (:file "command-query") (:file "command-field-list") (:file "command-refresh") (:file "command-shutdown") (:file "command-statistics") (:file "command-process-information") (:file "command-process-kill") (:file "command-debug") (:file "command-ping") (:file "command-change-user"))) (:module "prepared-statements" :serial nil :depends-on ("connection" "response-result-set") :components ((:file "binary-protocol-encoding") (:file "prepared-statement" :depends-on ("binary-protocol-encoding")))))) (:file "api" :depends-on ("mysql-protocol"))))) :in-order-to ((test-op (load-op :qmynd-test))) :perform (test-op :after (o c) (funcall (read-from-string "qmynd-test::run-all-tests")))) qmynd-20170630-git/src/000077500000000000000000000000001312441320500144515ustar00rootroot00000000000000qmynd-20170630-git/src/api.lisp000066400000000000000000000162351312441320500161220ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Connection entry-point (defun mysql-connect (&key (host "localhost") (port 3306) (username "") (password "") database (client-found-rows nil) (compress nil) (ssl :unspecified) ssl-verify) "Connect to a MySQL over a network (AF_INET) socket and begin the MySQL Handshake. Returns a QMYND:MYSQL-CONNECTION object or signals a QMYND:MYSQL-ERROR. Accepts the following keyword arguments: HOST: The host to connect to. (default: \"localhost\") PORT: The port to connect to. (default: 3306) USERNAME: User to authenticate as. PASSWORD: Password to authenticate with. DATABASE: What database to use upon connecting. (default: nil) CLIENT-FOUND-ROWS: Whether or not to require the client-found-rows feature from the server (default: nil) COMPRESS: Whether or not to use compression. (default: nil). SSL: Whether or not to use SSL. (default: :UNSPECIFIED) T - Forces SSL (or error out if it's not available). NIL - Disable SSL, even if it is available. :UNSPECIFIED - Opportunistic use of SSL. SSL-VERIFY: Whether or not to verify the SSL certificate presented by the server. (Default: nil)" ;; Open Socket (let* ((socket (usocket:socket-connect host port :protocol :stream :element-type '(unsigned-byte 8))) (connection (make-instance 'mysql-inet-connection :socket socket :stream (usocket:socket-stream socket) :default-schema database))) (mysql-connect-do-handshake connection username password database :client-found-rows client-found-rows :compress compress :ssl ssl :ssl-verify ssl-verify))) ;;; AF_LOCAL sockets should really be folded into usocket. For now, just implement CCL and SBCL support. #+(or ccl sbcl ecl) (defun mysql-local-connect (&key (path #P"/var/run/mysqld/mysqld.sock") (username "") (password "") database (client-found-rows nil)) "Connect to a MySQL over a local (AF_LOCAL) socket and begin the MySQL Handshake. Returns a QMYND:MYSQL-CONNECTION object or signals a QMYND:MYSQL-ERROR. Accepts the following keyword arguments: PATH: The path of the local socket to connect to. (default: #P\"/var/run/mysqld/mysqld.sock\") USERNAME: User to authenticate as. PASSWORD: Password to authenticate with. DATABASE: What database to use upon connecting. (default: nil) CLIENT-FOUND-ROWS: Whether or not to require the client-found-rows feature from the server (default: nil)" ;; Open Socket (let* ((socket #+ccl (ccl:make-socket :address-family :file :connect :active :remote-filename path) #+(or sbcl ecl) (let ((socket (make-instance 'sb-bsd-sockets:local-socket :type :stream))) (sb-bsd-sockets:socket-connect socket (etypecase path (pathname (namestring path)) (string path))) socket) ) (connection (make-instance 'mysql-local-connection :socket socket :stream #+ccl socket #+(or sbcl ecl) (sb-bsd-sockets:socket-make-stream socket :input t :output t :element-type '(unsigned-byte 8)) :default-schema database))) (mysql-connect-do-handshake connection username password database :client-found-rows client-found-rows :ssl nil))) (defmethod mysql-disconnect ((c mysql-base-connection)) "Shut down a MySQL connection." (when (mysql-connection-connected c) (with-mysql-connection (c) (send-command-quit)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Simple SQL Queries (defun mysql-query (connection query-string &key row-fn (as-text nil) (result-type 'vector)) "Send a SQL Query over the connection using the MySQL Text Protocol. For queries that return rows, returns two values: A vector of rows, each of which is a vector of columns. A vector of column descriptors. For queries that don't return rows, returns a QMYND:RESPONSE-OK-PACKET. May signal a QMYND:MYSQL-ERROR." (with-mysql-connection (connection) (send-command-query query-string :row-fn row-fn :as-text as-text :result-type result-type))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Prepared Statements (defun mysql-statement-prepare (connection query-string) "Prepares a SQL Query using the MySQL Prepared Statement Protocol. Returns a QMYND:MYSQL-PREPARED-STATEMENT. NB: The QMYND:MYSQL-PREPARED-STATEMENT remembers the QMYND:MYSQL-CONNECTION it was prepared for." (with-mysql-connection (connection) (send-command-statement-prepare query-string))) (defmethod mysql-statement-execute ((statement mysql-prepared-statement) &key parameters) "Executes a QMYND:MYSQL-PREPARED-STATEMENT. Accepts the following keyword arguments: PARAMETERS: a sequence of parameters for the placeholders in the prepared statement, if any." (let ((connection (mysql-prepared-statement-connection statement))) (unless connection (error 'invalid-prepared-statement)) (with-mysql-connection (connection) (send-command-statement-execute statement :parameters parameters)))) (defmethod mysql-statement-close ((statement mysql-prepared-statement)) "Deallocates and invalidates STATEMENT." (let ((connection (mysql-prepared-statement-connection statement))) (unless connection (error 'invalid-prepared-statement)) (with-mysql-connection (connection) (send-command-statement-close statement) (mysql-connection-remove-stale-prepared-statements *mysql-connection*) (values)))) qmynd-20170630-git/src/common/000077500000000000000000000000001312441320500157415ustar00rootroot00000000000000qmynd-20170630-git/src/common/charsets.lisp000066400000000000000000000347741312441320500204650ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) (eval-when (:compile-toplevel :load-toplevel :execute) ;; Character Sets (partially taken from +MYSQL+/sql/share/charsets/Index.xml) ;; ;; See also http://bugs.mysql.com/bug.php?id=22456 ;; ;; and ;; http://bazaar.launchpad.net/~mysql/connectorj/5.1/view/head:/src/com/mysql/jdbc/CharsetMapping.java (defconstant +mysql-cs-coll-big5-chinese-ci+ 1) (defconstant +mysql-cs-coll-latin2-czech-cs+ 2) (defconstant +mysql-cs-coll-dec8-swedish-ci+ 3) (defconstant +mysql-cs-coll-cp850-general-ci+ 4) (defconstant +mysql-cs-coll-latin1-german1-ci+ 5) (defconstant +mysql-cs-coll-hp8-english-ci+ 6) (defconstant +mysql-cs-coll-koi8r-general-ci+ 7) (defconstant +mysql-cs-coll-latin1-swedish-ci+ 8) (defconstant +mysql-cs-coll-latin2-general-ci+ 9) (defconstant +mysql-cs-coll-swe7-swedish-ci+ 10) (defconstant +mysql-cs-coll-ascii-general-ci+ 11) (defconstant +mysql-cs-coll-ujis-japanese-ci+ 12) (defconstant +mysql-cs-coll-sjis-japanese-ci+ 13) (defconstant +mysql-cs-coll-cp1251-bulgarian-ci+ 14) (defconstant +mysql-cs-coll-latin1-danish-ci+ 15) (defconstant +mysql-cs-coll-hebrew-general-ci+ 16) (defconstant +mysql-cs-coll-win1251+ 17) ; removed since 4.1 (defconstant +mysql-cs-coll-tis620-thai-ci+ 18) (defconstant +mysql-cs-coll-euckr-korean-ci+ 19) (defconstant +mysql-cs-coll-latin7-estonian-cs+ 20) (defconstant +mysql-cs-coll-latin2-hungarian-ci+ 21) (defconstant +mysql-cs-coll-koi8u-general-ci+ 22) (defconstant +mysql-cs-coll-cp1251-ukrainian-ci+ 23) (defconstant +mysql-cs-coll-gb2312-chinese-ci+ 24) (defconstant +mysql-cs-coll-greek-general-ci+ 25) (defconstant +mysql-cs-coll-cp1250-general-ci+ 26) (defconstant +mysql-cs-coll-latin2-croatian-ci+ 27) (defconstant +mysql-cs-coll-gbk-chinese-ci+ 28) (defconstant +mysql-cs-coll-cp1257-lithuanian-ci+ 29) (defconstant +mysql-cs-coll-latin5-turkish-ci+ 30) (defconstant +mysql-cs-coll-latin1-german2-ci+ 31) (defconstant +mysql-cs-coll-armscii8-general-ci+ 32) (defconstant +mysql-cs-coll-utf8-general-ci+ 33) (defconstant +mysql-cs-coll-cp1250-czech-cs+ 34) (defconstant +mysql-cs-coll-ucs2-general-ci+ 35) (defconstant +mysql-cs-coll-cp866-general-ci+ 36) (defconstant +mysql-cs-coll-keybcs2-general-ci+ 37) (defconstant +mysql-cs-coll-macce-general-ci+ 38) (defconstant +mysql-cs-coll-macroman-general-ci+ 39) (defconstant +mysql-cs-coll-cp852-general-ci+ 40) (defconstant +mysql-cs-coll-latin7-general-ci+ 41) (defconstant +mysql-cs-coll-latin7-general-cs+ 42) (defconstant +mysql-cs-coll-macce-binary+ 43) (defconstant +mysql-cs-coll-cp1250-croatian-ci+ 44) (defconstant +mysql-cs-coll-utf8mb4-general-ci+ 45) (defconstant +mysql-cs-coll-utf8mb4-binary+ 46) (defconstant +mysql-cs-coll-latin1-binary+ 47) (defconstant +mysql-cs-coll-latin1-general-ci+ 48) (defconstant +mysql-cs-coll-latin1-general-cs+ 49) (defconstant +mysql-cs-coll-cp1251-binary+ 50) (defconstant +mysql-cs-coll-cp1251-general-ci+ 51) (defconstant +mysql-cs-coll-cp1251-general-cs+ 52) (defconstant +mysql-cs-coll-macroman-binary+ 53) (defconstant +mysql-cs-coll-utf16-general-ci+ 54) (defconstant +mysql-cs-coll-utf16-binary+ 55) (defconstant +mysql-cs-coll-utf16le-general-ci+ 56) (defconstant +mysql-cs-coll-cp1256-general-ci+ 57) (defconstant +mysql-cs-coll-cp1257-binary+ 58) (defconstant +mysql-cs-coll-cp1257-general-ci+ 59) (defconstant +mysql-cs-coll-utf32-general-ci+ 60) (defconstant +mysql-cs-coll-utf32-binary+ 61) (defconstant +mysql-cs-coll-utf16le-binary+ 62) (defconstant +mysql-cs-coll-binary+ 63) (defconstant +mysql-cs-coll-armscii8-binary+ 64) (defconstant +mysql-cs-coll-ascii-binary+ 65) (defconstant +mysql-cs-coll-cp1250-binary+ 66) (defconstant +mysql-cs-coll-cp1256-binary+ 67) (defconstant +mysql-cs-coll-cp866-binary+ 68) (defconstant +mysql-cs-coll-dec8-binary+ 69) (defconstant +mysql-cs-coll-greek-binary+ 70) (defconstant +mysql-cs-coll-hebrew-binary+ 71) (defconstant +mysql-cs-coll-hp8-binary+ 72) (defconstant +mysql-cs-coll-keybcs2-binary+ 73) (defconstant +mysql-cs-coll-koi8r-binary+ 74) (defconstant +mysql-cs-coll-koi8u-binary+ 75) ;;; 76 is NOT USED (defconstant +mysql-cs-coll-latin2-binary+ 77) (defconstant +mysql-cs-coll-latin5-binary+ 78) (defconstant +mysql-cs-coll-latin7-binary+ 79) (defconstant +mysql-cs-coll-cp850-binary+ 80) (defconstant +mysql-cs-coll-cp852-binary+ 81) (defconstant +mysql-cs-coll-swe7-binary+ 82) (defconstant +mysql-cs-coll-utf8-binary+ 83) (defconstant +mysql-cs-coll-big5-binary+ 84) (defconstant +mysql-cs-coll-euckr-binary+ 85) (defconstant +mysql-cs-coll-gb2312-binary+ 86) (defconstant +mysql-cs-coll-gbk-binary+ 87) (defconstant +mysql-cs-coll-sjis-binary+ 88) (defconstant +mysql-cs-coll-tis620-binary+ 89) (defconstant +mysql-cs-coll-ucs2-binary+ 90) (defconstant +mysql-cs-coll-ujis-binary+ 91) (defconstant +mysql-cs-coll-geostd8-general-ci+ 92) (defconstant +mysql-cs-coll-geostd8-binary+ 93) (defconstant +mysql-cs-coll-latin1-spanish-ci+ 94) (defconstant +mysql-cs-coll-cp932-japanese-ci+ 95) (defconstant +mysql-cs-coll-cp932-binary+ 96) (defconstant +mysql-cs-coll-eucjpms-japanese-ci+ 97) (defconstant +mysql-cs-coll-eucjpms-binary+ 98) (defconstant +mysql-cs-coll-cp1250-polish-ci+ 99) ;;; 100 is NOT USED (defconstant +mysql-cs-coll-utf16-unicode-ci+ 101) (defconstant +mysql-cs-coll-utf16-icelandic-ci+ 102) (defconstant +mysql-cs-coll-utf16-latvian-ci+ 103) (defconstant +mysql-cs-coll-utf16-romanian-ci+ 104) (defconstant +mysql-cs-coll-utf16-slovenian-ci+ 105) (defconstant +mysql-cs-coll-utf16-polish-ci+ 106) (defconstant +mysql-cs-coll-utf16-estonian-ci+ 107) (defconstant +mysql-cs-coll-utf16-spanish-ci+ 108) (defconstant +mysql-cs-coll-utf16-swedish-ci+ 109) (defconstant +mysql-cs-coll-utf16-turkish-ci+ 110) (defconstant +mysql-cs-coll-utf16-czech-ci+ 111) (defconstant +mysql-cs-coll-utf16-danish-ci+ 112) (defconstant +mysql-cs-coll-utf16-lithuanian-ci+ 113) (defconstant +mysql-cs-coll-utf16-slovak-ci+ 114) (defconstant +mysql-cs-coll-utf16-spanish2-ci+ 115) (defconstant +mysql-cs-coll-utf16-roman-ci+ 116) (defconstant +mysql-cs-coll-utf16-persian-ci+ 117) (defconstant +mysql-cs-coll-utf16-esperanto-ci+ 118) (defconstant +mysql-cs-coll-utf16-hungarian-ci+ 119) (defconstant +mysql-cs-coll-utf16-sinhala-ci+ 120) (defconstant +mysql-cs-coll-utf16-german2-ci+ 121) (defconstant +mysql-cs-coll-utf16-croatian-ci+ 122) (defconstant +mysql-cs-coll-utf16-unicode-520-ci+ 123) (defconstant +mysql-cs-coll-utf16-vietnamese-ci+ 124) ;;; 125 is NOT USED ;;; 126 is NOT USED ;;; 127 is NOT USED (defconstant +mysql-cs-coll-ucs2-unicode-ci+ 128) (defconstant +mysql-cs-coll-ucs2-icelandic-ci+ 129) (defconstant +mysql-cs-coll-ucs2-latvian-ci+ 130) (defconstant +mysql-cs-coll-ucs2-romanian-ci+ 131) (defconstant +mysql-cs-coll-ucs2-slovenian-ci+ 132) (defconstant +mysql-cs-coll-ucs2-polish-ci+ 133) (defconstant +mysql-cs-coll-ucs2-estonian-ci+ 134) (defconstant +mysql-cs-coll-ucs2-spanish-ci+ 135) (defconstant +mysql-cs-coll-ucs2-swedish-ci+ 136) (defconstant +mysql-cs-coll-ucs2-turkish-ci+ 137) (defconstant +mysql-cs-coll-ucs2-czech-ci+ 138) (defconstant +mysql-cs-coll-ucs2-danish-ci+ 139) (defconstant +mysql-cs-coll-ucs2-lithuanian-ci+ 140) (defconstant +mysql-cs-coll-ucs2-slovak-ci+ 141) (defconstant +mysql-cs-coll-ucs2-spanish2-ci+ 142) (defconstant +mysql-cs-coll-ucs2-roman-ci+ 143) (defconstant +mysql-cs-coll-ucs2-persian-ci+ 144) (defconstant +mysql-cs-coll-ucs2-esperanto-ci+ 145) (defconstant +mysql-cs-coll-ucs2-hungarian-ci+ 146) (defconstant +mysql-cs-coll-ucs2-sinhala-ci+ 147) (defconstant +mysql-cs-coll-ucs2-german2-ci+ 148) (defconstant +mysql-cs-coll-ucs2-croatian-ci+ 149) (defconstant +mysql-cs-coll-ucs2-unicode-520-ci+ 150) (defconstant +mysql-cs-coll-ucs2-vietnamese-ci+ 151) ;;; 152 is NOT USED ;;; 153 is NOT USED ;;; 154 is NOT USED ;;; 155 is NOT USED ;;; 156 is NOT USED ;;; 157 is NOT USED ;;; 158 is NOT USED (defconstant +mysql-cs-coll-ucs2-general-mysql500-ci+ 159) (defconstant +mysql-cs-coll-utf32-unicode-ci+ 160) (defconstant +mysql-cs-coll-utf32-icelandic-ci+ 161) (defconstant +mysql-cs-coll-utf32-latvian-ci+ 162) (defconstant +mysql-cs-coll-utf32-romanian-ci+ 163) (defconstant +mysql-cs-coll-utf32-slovenian-ci+ 164) (defconstant +mysql-cs-coll-utf32-polish-ci+ 165) (defconstant +mysql-cs-coll-utf32-estonian-ci+ 166) (defconstant +mysql-cs-coll-utf32-spanish-ci+ 167) (defconstant +mysql-cs-coll-utf32-swedish-ci+ 168) (defconstant +mysql-cs-coll-utf32-turkish-ci+ 169) (defconstant +mysql-cs-coll-utf32-czech-ci+ 170) (defconstant +mysql-cs-coll-utf32-danish-ci+ 171) (defconstant +mysql-cs-coll-utf32-lithuanian-ci+ 172) (defconstant +mysql-cs-coll-utf32-slovak-ci+ 173) (defconstant +mysql-cs-coll-utf32-spanish2-ci+ 174) (defconstant +mysql-cs-coll-utf32-roman-ci+ 175) (defconstant +mysql-cs-coll-utf32-persian-ci+ 176) (defconstant +mysql-cs-coll-utf32-esperanto-ci+ 177) (defconstant +mysql-cs-coll-utf32-hungarian-ci+ 178) (defconstant +mysql-cs-coll-utf32-sinhala-ci+ 179) (defconstant +mysql-cs-coll-utf32-german2-ci+ 180) (defconstant +mysql-cs-coll-utf32-croatian-ci+ 181) (defconstant +mysql-cs-coll-utf32-unicode-520-ci+ 182) (defconstant +mysql-cs-coll-utf32-vietnamese-ci+ 183) ;;; 184 is NOT USED ;;; 185 is NOT USED ;;; 186 is NOT USED ;;; 187 is NOT USED ;;; 188 is NOT USED ;;; 189 is NOT USED ;;; 190 is NOT USED ;;; 191 is NOT USED (defconstant +mysql-cs-coll-utf8-unicode-ci+ 192) (defconstant +mysql-cs-coll-utf8-icelandic-ci+ 193) (defconstant +mysql-cs-coll-utf8-latvian-ci+ 194) (defconstant +mysql-cs-coll-utf8-romanian-ci+ 195) (defconstant +mysql-cs-coll-utf8-slovenian-ci+ 196) (defconstant +mysql-cs-coll-utf8-polish-ci+ 197) (defconstant +mysql-cs-coll-utf8-estonian-ci+ 198) (defconstant +mysql-cs-coll-utf8-spanish-ci+ 199) (defconstant +mysql-cs-coll-utf8-swedish-ci+ 200) (defconstant +mysql-cs-coll-utf8-turkish-ci+ 201) (defconstant +mysql-cs-coll-utf8-czech-ci+ 202) (defconstant +mysql-cs-coll-utf8-danish-ci+ 203) (defconstant +mysql-cs-coll-utf8-lithuanian-ci+ 204) (defconstant +mysql-cs-coll-utf8-slovak-ci+ 205) (defconstant +mysql-cs-coll-utf8-spanish2-ci+ 206) (defconstant +mysql-cs-coll-utf8-roman-ci+ 207) (defconstant +mysql-cs-coll-utf8-persian-ci+ 208) (defconstant +mysql-cs-coll-utf8-esperanto-ci+ 209) (defconstant +mysql-cs-coll-utf8-hungarian-ci+ 210) (defconstant +mysql-cs-coll-utf8-sinhala-ci+ 211) (defconstant +mysql-cs-coll-utf8-german2-ci+ 212) (defconstant +mysql-cs-coll-utf8-croatian-ci+ 213) (defconstant +mysql-cs-coll-utf8-unicode-520-ci+ 214) (defconstant +mysql-cs-coll-utf8-vietnamese-ci+ 215) ;;; 216 is NOT USED ;;; 217 is NOT USED ;;; 218 is NOT USED ;;; 219 is NOT USED ;;; 220 is NOT USED ;;; 221 is NOT USED ;;; 222 is NOT USED (defconstant +mysql-cs-coll-utf8-general-mysql500-ci+ 223) (defconstant +mysql-cs-coll-utf8mb4-unicode-ci+ 224) (defconstant +mysql-cs-coll-utf8mb4-icelandic-ci+ 225) (defconstant +mysql-cs-coll-utf8mb4-latvian-ci+ 226) (defconstant +mysql-cs-coll-utf8mb4-romanian-ci+ 227) (defconstant +mysql-cs-coll-utf8mb4-slovenian-ci+ 228) (defconstant +mysql-cs-coll-utf8mb4-polish-ci+ 229) (defconstant +mysql-cs-coll-utf8mb4-estonian-ci+ 230) (defconstant +mysql-cs-coll-utf8mb4-spanish-ci+ 231) (defconstant +mysql-cs-coll-utf8mb4-swedish-ci+ 232) (defconstant +mysql-cs-coll-utf8mb4-turkish-ci+ 233) (defconstant +mysql-cs-coll-utf8mb4-czech-ci+ 234) (defconstant +mysql-cs-coll-utf8mb4-danish-ci+ 235) (defconstant +mysql-cs-coll-utf8mb4-lithuanian-ci+ 236) (defconstant +mysql-cs-coll-utf8mb4-slovak-ci+ 237) (defconstant +mysql-cs-coll-utf8mb4-spanish2-ci+ 238) (defconstant +mysql-cs-coll-utf8mb4-roman-ci+ 239) (defconstant +mysql-cs-coll-utf8mb4-persian-ci+ 240) (defconstant +mysql-cs-coll-utf8mb4-esperanto-ci+ 241) (defconstant +mysql-cs-coll-utf8mb4-hungarian-ci+ 242) (defconstant +mysql-cs-coll-utf8mb4-sinhala-ci+ 243) (defconstant +mysql-cs-coll-utf8mb4-german2-ci+ 244) (defconstant +mysql-cs-coll-utf8mb4-croatian-ci+ 245) (defconstant +mysql-cs-coll-utf8mb4-unicode-520-ci+ 246) (defconstant +mysql-cs-coll-utf8mb4-vietnamese-ci+ 247) ;;; 248 is NOT USED ;;; 249 is NOT USED ;;; 250 is NOT USED ;;; 251 is NOT USED ;;; 252 is NOT USED ;;; 253 is NOT USED (defconstant +mysql-cs-coll-utf8mb3-general-cs+ 254) ) ;eval-when qmynd-20170630-git/src/common/conditions.lisp000066400000000000000000000110141312441320500210000ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Library Base Conditions (define-condition mysql-base-error (error) () (:documentation "Base class for all QMyND MySQL errors.")) (define-condition mysql-internal-error (mysql-base-error) () (:documentation "Base class for all QMyND internal errors.")) (define-condition mysql-external-error (mysql-base-error) () (:documentation "Base class for all QMyND MySQL external (exported) errors.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Library Internal Errors (define-condition bad-mysql-type-spec (mysql-internal-error) ((text :initarg :text :reader bad-mysql-type-spec-text)) (:documentation "Signaled when we encounter a bad type spec in DEFINE-PACKET.")) (define-condition invalid-length-encoded-integer (mysql-internal-error) ((text :initarg :text :reader invalid-length-encoded-integer-text))) (define-condition unexpected-sequence-id (mysql-internal-error) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Exported Errors (define-condition mysql-error (mysql-external-error) ((code :initarg :code :reader mysql-error-code) (message :initarg :message :reader mysql-error-message) (state :initarg :state :reader mysql-error-state)) (:documentation "Wraps errors returned in MySQL Error Packets.") (:report (lambda (e s) (format s "MySQL Error [~A]: \"~A\"" (mysql-error-code e) (mysql-error-message e))))) (define-condition ssl-not-supported (mysql-external-error) () (:documentation "Signaled when SSL is requested but not supported.")) (define-condition invalid-prepared-statement (mysql-external-error) () (:documentation "Signaled when trying to use an invalid MYSQL-PREPARED-STATEMENT.")) (define-condition unexpected-parameter-count (mysql-external-error) () (:documentation "Signaled when the wrong number of parameters are passed while calling #'MYSQL-STATEMENT-EXECUTE.")) (define-condition mysql-insufficient-capabilities (mysql-external-error) ((server-flags :initarg server-flags :reader mysql-insufficient-capabilities-server-flags)) (:documentation "Signaled when connecting to a server that does not meet the minimum requirements for the library.")) (define-condition mysql-unsupported-authentication (mysql-external-error) ((plugin :initarg :plugin :reader mysql-unsupported-authentication-plugin)) (:documentation "Signaled when trying to authenticate to a server with an unsupported authentication plugin.")) (define-condition unexpected-packet (mysql-external-error) ((payload :initarg :payload :reader unexpected-packet-payload)) (:documentation "Signaled when the library encounters an unexpected packet.")) (define-condition value-is-not-decimal (mysql-external-error) ((value :initarg :value)) (:documentation "Signaled when calling #'WRITE-DECIMAL-TO-STRING with a value that is not a decimal.")) (define-condition protocol-version-mismatch (mysql-external-error) ((version :initarg :version)) (:documentation "Signaled when the initial handshake returns an unknown protocol value.")) (define-condition partial-read (mysql-external-error) ((bytes :initarg :bytes :reader partial-read-bytes) (expected :initarg :expected :reader partial-read-expected)) (:documentation "Signaled when the library didn't get as many bytes as asked.") (:report (lambda (e s) (format s "MySQL ERROR: Partial Read of ~d bytes, expected ~d" (partial-read-bytes e) (partial-read-expected e)) (format s "~%Detail: check MySQL logs for (Got timeout writing communication packets)") (format s "~%Hint: adjust net_read_timeout and net_write_timeout")))) qmynd-20170630-git/src/common/constants.lisp000066400000000000000000000214001312441320500206430ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) (eval-when (:compile-toplevel :load-toplevel :execute) ;;; MySQL Commands ;; Text Protocol (15.6) (defconstant +mysql-command-sleep+ #x00) ;MySQL Internal (defconstant +mysql-command-quit+ #x01) (defconstant +mysql-command-initialize-database+ #x02) (defconstant +mysql-command-query+ #x03) (defconstant +mysql-command-field-list+ #x04) (defconstant +mysql-command-create-database+ #x05) ; deprecated (defconstant +mysql-command-drop-database+ #x06) ; deprecated (defconstant +mysql-command-refresh+ #x07) (defconstant +mysql-command-shutdown+ #x08) (defconstant +mysql-command-statistics+ #x09) (defconstant +mysql-command-process-information+ #x0a) ; deprecated (5.16.11) (defconstant +mysql-command-connect+ #x0b) ;MySQL Internal (defconstant +mysql-command-process-kill+ #x0c) (defconstant +mysql-command-debug+ #x0d) ;Requires SUPER priviledge (defconstant +mysql-command-ping+ #x0e) (defconstant +mysql-command-time+ #x0f) ;MySQL Internal (defconstant +mysql-command-delayed-insert+ #x10) ;MySQL Internal (defconstant +mysql-command-change-user+ #x11) (defconstant +mysql-command-daemon+ #x1d) ;MySQL Internal ;; Prepared Statements (defconstant +mysql-command-statement-prepare+ #x16) (defconstant +mysql-command-statement-execute+ #x17) (defconstant +mysql-command-statement-send-long-data+ #x18) (defconstant +mysql-command-statement-close+ #x19) (defconstant +mysql-command-statement-reset+ #x1a) ;; Stored Procedures (defconstant +mysql-command-set-option+ #x1b) (defconstant +mysql-command-statement-fetch+ #x1c) ;; Replication Protocol (not supported by this library) (defconstant +mysql-command-binary-log-dump+ #x12) (defconstant +mysql-command-table-dump+ #x13) (defconstant +mysql-command-connect-out+ #x14) (defconstant +mysql-command-register-slave+ #x15) (defconstant +mysql-command-binary-log-dump-gtid+ #x1e) ;; Response types (defconstant +mysql-response-ok+ #x00) (defconstant +mysql-response-end-of-file+ #xfe) (defconstant +mysql-response-error+ #xff) ;; Shutdown types (15.6.9) ;; NB: Only +mysql-shutdown-wait-all-buffers+ is used (defconstant +mysql-shutdown-default+ #x00) (defconstant +mysql-shutdown-wait-connections+ #x01) (defconstant +mysql-shutdown-wait-transactions+ #x02) (defconstant +mysql-shutdown-wait-updates+ #x08) (defconstant +mysql-shutdown-wait-all-buffers+ #x10) (defconstant +mysql-shutdown-wait-critical-buffers+ #x11) (defconstant +mysql-shutdown-kill-query+ #xfe) (defconstant +mysql-shutdown-kill-connection+ #xff) ;; Capability Flags (15.2.6) (defconstant +mysql-capability-client-long-password+ #x1) (defconstant +mysql-capability-client-found-rows+ #x2) (defconstant +mysql-capability-client-long-flag+ #x4) (defconstant +mysql-capability-client-connect-with-db+ #x8) (defconstant +mysql-capability-client-no-schema+ #x10) (defconstant +mysql-capability-client-compress+ #x20) (defconstant +mysql-capability-client-odbc+ #x40) (defconstant +mysql-capability-client-local-files+ #x80) (defconstant +mysql-capability-client-ignore-space+ #x100) (defconstant +mysql-capability-client-protocol-41+ #x200) ;; CLIENT_CHANGE_USER in v3.22; unused in v4.0 (defconstant +mysql-capability-client-interactive+ #x400) (defconstant +mysql-capability-client-ssl+ #x800) (defconstant +mysql-capability-client-ignore-sigpipe+ #x1000) (defconstant +mysql-capability-client-transactions+ #x2000) ;; Always set by server since v4.0 (defconstant +mysql-capability-client-reserved+ #x4000) ;; CLIENT_PROTOCOL_41 in v4.1.0; deprecated v4.1.1 (defconstant +mysql-capability-client-secure-connection+ #x8000) (defconstant +mysql-capability-client-multi-statements+ #x10000) ;; Requires CLIENT_PROTOCOL_41 (defconstant +mysql-capability-client-multi-results+ #x20000) ;; Requires CLIENT_PROTOCOL_41 (defconstant +mysql-capability-client-ps-multi-results+ #x40000) ;; Requires CLIENT_PROTOCOL_41 ;;; NB: There are no immediate plans to support these capabilities. (defconstant +mysql-capability-client-plugin-auth+ #x80000) ;; New in v5.5.7; Requires CLIENT_PROTOCOL_41 (defconstant +mysql-capability-client-connect-attrs+ #x100000) ;; New in v5.6.6 (defconstant +mysql-capability-client-plugin-auth-lenec-client-data+ #x200000) ;; New in v5.6.7 (defconstant +mysql-capability-client-verify-server-cert+ #x40000000) ;; Not used; specify :SSL-VERIFY T at connect time. (defconstant +mysql-capability-client-remember-options+ #x80000000) ;; Not used. (defconstant +mysql-capabilities-required+ (logior +mysql-capability-client-long-flag+ +mysql-capability-client-connect-with-db+ ; required of server; client use not required. +mysql-capability-client-protocol-41+ +mysql-capability-client-transactions+ +mysql-capability-client-secure-connection+) "The minimum required capabilities for this client to interop with a MySQL server.") ;; Status flags (15.1.3.1) (defconstant +mysql-server-status-in-transaction+ #x1) (defconstant +mysql-server-status-autocommit+ #x2) ;;; #x4 ? (defconstant +mysql-server-more-results-exist+ #x8) (defconstant +mysql-server-status-no-good-index-used+ #x10) (defconstant +mysql-server-status-no-index-used+ #x20) (defconstant +mysql-server-status-cursor-exists+ #x40) (defconstant +mysql-server-server-status-last-row-sent+ #x80) (defconstant +mysql-server-status-database-dropped+ #x100) (defconstant +mysql-server-status-no-backslash-escapes+ #x200) (defconstant +mysql-server-status-metadata-changed+ #x400) (defconstant +mysql-server-query-was-slow+ #x800) (defconstant +mysql-server-ps-out-params+ #x1000) ;; Column Types (15.6.4.1.1.1) (defconstant +mysql-type-decimal+ #x00) (defconstant +mysql-type-tiny+ #x01) (defconstant +mysql-type-short+ #x02) (defconstant +mysql-type-long+ #x03) (defconstant +mysql-type-float+ #x04) (defconstant +mysql-type-double+ #x05) (defconstant +mysql-type-null+ #x06) (defconstant +mysql-type-timestamp+ #x07) (defconstant +mysql-type-longlong+ #x08) (defconstant +mysql-type-int24+ #x09) (defconstant +mysql-type-date+ #x0a) (defconstant +mysql-type-time+ #x0b) (defconstant +mysql-type-datetime+ #x0c) (defconstant +mysql-type-year+ #x0d) (defconstant +mysql-type-newdate+ #x0e) (defconstant +mysql-type-varchar+ #x0f) (defconstant +mysql-type-bit+ #x10) (defconstant +mysql-type-newdecimal+ #xf6) (defconstant +mysql-type-enum+ #xf7) (defconstant +mysql-type-set+ #xf8) (defconstant +mysql-type-tiny-blob+ #xf9) (defconstant +mysql-type-medium-blob+ #xfa) (defconstant +mysql-type-long-blob+ #xfb) (defconstant +mysql-type-blob+ #xfc) (defconstant +mysql-type-var-string+ #xfd) (defconstant +mysql-type-string+ #xfe) (defconstant +mysql-type-geometry+ #xff) ;; Column Description Flags (defconstant +mysql-flag-column-non-nullable+ #x01) (defconstant +mysql-flag-column-primary-key+ #x02) (defconstant +mysql-flag-column-unique-key+ #x04) (defconstant +mysql-flag-column-multiple-key+ #x08) (defconstant +mysql-flag-column-blob+ #x10) (defconstant +mysql-flag-column-unsigned+ #x20) (defconstant +mysql-flag-column-zero-fill+ #x40) (defconstant +mysql-flag-column-binary+ #x80) ;; Command Refresh flags (15.6.8) (defconstant +mysql-refresh-grant+ #x01) (defconstant +mysql-refresh-log+ #x02) (defconstant +mysql-refresh-tables+ #x04) (defconstant +mysql-refresh-hosts+ #x08) (defconstant +mysql-refresh-status+ #x10) (defconstant +mysql-refresh-threads+ #x20) (defconstant +mysql-refresh-slave+ #x40) (defconstant +mysql-refresh-master+ #x80) ;; Date-Time (defconstant +seconds-per-minute+ 60) (defconstant +minutes-per-hour+ 60) (defconstant +hours-per-day+ 24) (defconstant +mysql-minimum-compression-length+ 50) ) ;eval-when (defun mysql-capabilities-supported () "Returns the full set of capabilities supported by this client library." (logior +mysql-capabilities-required+ +mysql-capability-client-connect-with-db+ +mysql-capability-client-plugin-auth+ (if (have-ssl) +mysql-capability-client-ssl+ 0) (if (have-compression) +mysql-capability-client-compress+ 0) ;;+mysql-capability-client-no-schema+ ;;+mysql-capability-client-ignore-space+ ;;+mysql-capability-client-multi-statements+ ;;+mysql-capability-client-multi-results+ ;;+mysql-capability-client-ps-multi-results+ ;;+mysql-capability-client-connect-attrs+ )) qmynd-20170630-git/src/common/date-time.lisp000066400000000000000000000217041312441320500205070ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; MySQL DateTime ;; MySQL can validate dates in several ways depending on how the server is configured. Rather than ;; enforcing anything here, we'll allow for the most liberal specification and let the server tell ;; us when we're wrong. (defclass mysql-date-time () ((year :type (integer 0 #xffff) :accessor mysql-date-time-year :initarg :year :initform 0) (month :type (integer 0 12) :accessor mysql-date-time-month :initarg :month :initform 0) (day :type (integer 0 31) :accessor mysql-date-time-day :initarg :day :initform 0) (hour :type (integer 0 23) :accessor mysql-date-time-hour :initarg :hour :initform 0) (minute :type (integer 0 59) :accessor mysql-date-time-minute :initarg :minute :initform 0) (second :type (integer 0 59) :accessor mysql-date-time-second :initarg :second :initform 0) (microsecond :type (integer 0 999999) :accessor mysql-date-time-microsecond :initarg :microsecond :initform 0))) (defmethod print-object ((date-time mysql-date-time) stream) (with-prefixed-accessors (year month day hour minute second microsecond) (mysql-date-time- date-time) (format stream "#" year month day hour minute second microsecond))) (defun mysql-date-time-to-universal-time (date-time) "Converts a MySQL DateTime to a Lisp integer-time. Returns NIL if all elements of the date-time are zero." (assert (typep date-time 'mysql-date-time)) (with-prefixed-accessors (year month day hour minute second microsecond) (mysql-date-time- date-time) (unless (every #'zerop (list year month day hour minute second microsecond)) (assert (>= year 1900)) ;; asedeno-TODO: log loss of microseconds if non-zero (values (encode-universal-time second minute hour day month year 0) microsecond)))) (defun universal-time-to-mysql-date-time (integer-time &optional (microseconds 0)) "Converts a Lisp integer-time to a MySQL DateTime. If integer-time is NIL, returns a MySQL DateTime with all elements set to zero." (assert (typep integer-time '(or integer null))) (if integer-time (multiple-value-bind (second minute hour day month year tz) (decode-universal-time integer-time 0) (declare (ignore tz)) (make-instance 'mysql-date-time :year year :month month :day day :hour hour :minute minute :second second :microsecond microseconds)) (make-instance 'mysql-date-time))) (defun parse-date-time-string (str) "Parses a date-time-string in one of the following forms and returns a MYSQL-DATE-TIME object. \"\" -- All fields = 0 \"YYYY-MM-DD\" -- All time fields = 0 \"YYYY-MM-DD hh:mm:ss\" -- Microseconds = 0 \"YYYY-MM-DD hh:mm:ss.µµµµµµ\"" (let ((year 0) (month 0) (day 0) (hour 0) (minute 0) (second 0) (microsecond 0) (length (length str))) (when (> length 0) ;; YYYY-MM-DD (setf year (parse-integer str :start 0 :end 4) month (parse-integer str :start 5 :end 7) day (parse-integer str :start 8 :end 10))) (when (> length 10) ;; YYYY-MM-DD hh:mm:ss (setf hour (parse-integer str :start 11 :end 13) minute (parse-integer str :start 14 :end 16) second (parse-integer str :start 17 :end 19))) (when (> length 19) ;; YYYY-MM-DD hh:mm:ss.µµµµµµ (setf microsecond (parse-integer str :start 20 :end 26))) (make-instance 'mysql-date-time :year year :month month :day day :hour hour :minute minute :second second :microsecond microsecond))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; MySQL Time Interval (defclass mysql-time-interval () ((negativep :type boolean :accessor mysql-time-interval-negativep :initarg :negativep :initform nil) (days :type (integer 0 #xffffffff) :accessor mysql-time-interval-days :initarg :days :initform 0) (hours :type (integer 0 23) :accessor mysql-time-interval-hours :initarg :hours :initform 0) (minutes :type (integer 0 59) :accessor mysql-time-interval-minutes :initarg :minutes :initform 0) (seconds :type (integer 0 59) :accessor mysql-time-interval-seconds :initarg :seconds :initform 0) (microseconds :type (integer 0 999999) :accessor mysql-time-interval-microseconds :initarg :microseconds :initform 0))) (defmethod print-object ((interval mysql-time-interval) stream) (with-prefixed-accessors (negativep days hours minutes seconds microseconds) (mysql-time-interval- interval) (format stream "#" (if negativep "-" "") (+ (* 24 days) hours) minutes seconds microseconds))) (defun mysql-time-interval-to-seconds (interval) "Converts a MYSQL-TIME-INTERVAL to a whole number of seconds. Returns microseconds as a second value." (assert (typep interval 'mysql-time-interval)) (with-prefixed-accessors (negativep days hours minutes seconds microseconds) (mysql-time-interval- interval) (values (* (if negativep -1 1) (+ seconds (* +seconds-per-minute+ (+ minutes (* +minutes-per-hour+ (+ hours (* +hours-per-day+ days))))))) microseconds))) (defun seconds-to-mysql-time-interval (value &optional (microseconds 0)) "Creates a MYSQL-TIME-INTERVAL representing VALUE seconds. An optional second argument can be used to specify microseconds." (assert (typep value 'integer)) (let ((negativep (minusp value)) (value (abs value))) (multiple-value-bind (value seconds) (truncate value +seconds-per-minute+) (multiple-value-bind (value minutes) (truncate value +minutes-per-hour+) (multiple-value-bind (days hours) (truncate value +hours-per-day+) (make-instance 'mysql-time-interval :negativep negativep :days days :hours hours :minutes minutes :seconds seconds :microseconds microseconds)))))) (defun parse-time-interval-string (str) "Parses the MySQL Text Protocol represetation of a time interval. /(-)?(h+):(mm):(ss).(µµµµµµ)/" (let ((negativep (string-prefix-p "-" str))) (multiple-value-bind (hours end) (parse-integer str :start (if negativep 1 0) :junk-allowed t) (multiple-value-bind (days hours) (truncate hours 24) (multiple-value-bind (minutes end) (parse-integer str :start (1+ end) :junk-allowed t) (multiple-value-bind (seconds end) (parse-integer str :start (1+ end) :junk-allowed t) (let ((microseconds (if (> (length str) end) (parse-integer str :start (1+ end)) 0))) (make-instance 'mysql-time-interval :days days :hours hours :minutes minutes :seconds seconds :microseconds microseconds)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; MySQL Year (defclass mysql-year () ((year :type (integer 0 #xffff) :accessor mysql-year-year :initarg :year :initform 0))) (defmethod print-object ((year mysql-year) stream) (with-prefixed-accessors (year) (mysql-year- year) (format stream "#" year))) qmynd-20170630-git/src/common/feature-detection.lisp000066400000000000000000000014661312441320500222500ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) (defun have-ssl () (find-package "CL+SSL")) (defun have-compression () (and (find-package "CHIPZ") (find-package "SALZA2"))) qmynd-20170630-git/src/common/misc.lisp000066400000000000000000000336201312441320500175710ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;; Stuff in here should find a more permanent home as the library ;;; evolves. (defun mysql-cs-coll-to-character-encoding (cs-coll) "Maps a MySQL Character Set / Collation identifier to an encoding." (ecase cs-coll ;; (#. +mysql-cs-coll-big5-chinese-ci+ :unknown) (#. +mysql-cs-coll-latin2-czech-cs+ :iso-8859-2) (#. +mysql-cs-coll-dec8-swedish-ci+ :iso-8859-1) ; punting (#. +mysql-cs-coll-cp850-general-ci+ :iso-8859-1) ; punting (#. +mysql-cs-coll-latin1-german1-ci+ :iso-8859-1) (#. +mysql-cs-coll-hp8-english-ci+ :iso-8859-1) ; punting ;; (#. +mysql-cs-coll-koi8r-general-ci+ :unknown) (#. +mysql-cs-coll-latin1-swedish-ci+ :iso-8859-1) (#. +mysql-cs-coll-latin2-general-ci+ :iso-8859-2) (#. +mysql-cs-coll-swe7-swedish-ci+ :iso-8859-2) (#. +mysql-cs-coll-ascii-general-ci+ :us-ascii) ;; (#. +mysql-cs-coll-ujis-japanese-ci+ :unknown) ;; (#. +mysql-cs-coll-sjis-japanese-ci+ :unknown) (#. +mysql-cs-coll-cp1251-bulgarian-ci+ :cp1251) (#. +mysql-cs-coll-latin1-danish-ci+ :iso-8859-1) ;; (#. +mysql-cs-coll-hebrew-general-ci+ :unknown) (#. +mysql-cs-coll-win1251+ :cp1251) ;; (#. +mysql-cs-coll-tis620-thai-ci+ :unknown) ;; (#. +mysql-cs-coll-euckr-korean-ci+ :unknown) (#. +mysql-cs-coll-latin7-estonian-cs+ :iso-8859-7) (#. +mysql-cs-coll-latin2-hungarian-ci+ :iso-8859-2) ;; (#. +mysql-cs-coll-koi8u-general-ci+ :unknown) (#. +mysql-cs-coll-cp1251-ukrainian-ci+ :cp1251) ;; (#. +mysql-cs-coll-gb2312-chinese-ci+ :unknown) ;; (#. +mysql-cs-coll-greek-general-ci+ :unknown) ;; (#. +mysql-cs-coll-cp1250-general-ci+ :unknown) (#. +mysql-cs-coll-latin2-croatian-ci+ :iso-8859-2) (#. +mysql-cs-coll-gbk-chinese-ci+ :gbk) ;; (#. +mysql-cs-coll-cp1257-lithuanian-ci+ :unknown) (#. +mysql-cs-coll-latin5-turkish-ci+ :iso-8859-5) (#. +mysql-cs-coll-latin1-german2-ci+ :iso-8859-2) (#. +mysql-cs-coll-armscii8-general-ci+ :iso-8859-1) (#. +mysql-cs-coll-utf8-general-ci+ :utf-8) ;; (#. +mysql-cs-coll-cp1250-general-ci+ :unknown) (#. +mysql-cs-coll-ucs2-general-ci+ :ucs-2) ;; (#. +mysql-cs-coll-cp866-general-ci+ :unknown) ;; (#. +mysql-cs-coll-keybcs2-general-ci+ :unknown) ;; (#. +mysql-cs-coll-macce-general-ci+ :unknown) ;; (#. +mysql-cs-coll-macroman-general-ci+ :unknown) ;; (#. +mysql-cs-coll-cp852-general-ci+ :unknown) (#. +mysql-cs-coll-latin7-general-ci+ :iso-8859-13) ; latvian (#. +mysql-cs-coll-latin7-general-cs+ :iso-8859-13) ; latvian1 ;; (#. +mysql-cs-coll-macce-binary+ :unknown) ;; (#. +mysql-cs-coll-cp1250-croatian-ci+ :unknown) (#. +mysql-cs-coll-utf8mb4-general-ci+ :utf-8) (#. +mysql-cs-coll-utf8mb4-binary+ :utf-8) (#. +mysql-cs-coll-latin1-binary+ :iso-8859-1) (#. +mysql-cs-coll-latin1-general-ci+ :iso-8859-1) (#. +mysql-cs-coll-latin1-general-cs+ :iso-8859-1) (#. +mysql-cs-coll-cp1251-binary+ :cp1251) (#. +mysql-cs-coll-cp1251-general-ci+ :cp1251) (#. +mysql-cs-coll-cp1251-general-cs+ :cp1251) ;;; (#. +mysql-cs-coll-macroman-binary+ :unknown) (#. +mysql-cs-coll-utf16-general-ci+ :utf-16) (#. +mysql-cs-coll-utf16-binary+ :utf-16) (#. +mysql-cs-coll-utf16le-general-ci+ :utf-16le) ;; (#. +mysql-cs-coll-cp1256-general-ci+ :unknown) ;; (#. +mysql-cs-coll-cp1257-binary+ :unknown) ;; (#. +mysql-cs-coll-cp1257-general-ci+ :unknown) (#. +mysql-cs-coll-utf32-general-ci+ :utf-32) (#. +mysql-cs-coll-utf32-binary+ :utf-32) (#. +mysql-cs-coll-utf16le-binary+ :utf-16le) (#. +mysql-cs-coll-binary+ nil) (#. +mysql-cs-coll-armscii8-binary+ :iso-8859-2) ; punting armscii (#. +mysql-cs-coll-ascii-binary+ :us-ascii) ;; (#. +mysql-cs-coll-cp1250-binary+ :unknown) ;; (#. +mysql-cs-coll-cp1256-binary+ :unknown) ;; (#. +mysql-cs-coll-cp866-binary+ :unknown) (#. +mysql-cs-coll-dec8-binary+ :iso-8859-2) ; punting for dec8 ;; (#. +mysql-cs-coll-greek-binary+ :unknown) ;; (#. +mysql-cs-coll-hebrew-binary+ :unknown) (#. +mysql-cs-coll-hp8-binary+ :us-ascii) ;; (#. +mysql-cs-coll-keybcs2-binary+ :unknown) ;; (#. +mysql-cs-coll-koi8r-binary+ :unknown) ;; (#. +mysql-cs-coll-koi8u-binary+ :unknown) (#. +mysql-cs-coll-latin2-binary+ :iso-8859-2) (#. +mysql-cs-coll-latin5-binary+ :iso-8859-5) (#. +mysql-cs-coll-latin7-binary+ :iso-8859-7) ;; (#. +mysql-cs-coll-cp850-binary+ :unknown) ;; (#. +mysql-cs-coll-cp852-binary+ :unknown) (#. +mysql-cs-coll-swe7-binary+ :iso-8859-1) ; punting for swe7 (#. +mysql-cs-coll-utf8-binary+ :utf-8) ;; (#. +mysql-cs-coll-big5-binary+ :unknown) ;; (#. +mysql-cs-coll-euckr-binary+ :unknown) ;; (#. +mysql-cs-coll-gb2312-binary+ :unknown) (#. +mysql-cs-coll-gbk-binary+ :gbk) ;; (#. +mysql-cs-coll-sjis-binary+ :unknown) ;; (#. +mysql-cs-coll-tis620-binary+ :unknown) (#. +mysql-cs-coll-ucs2-binary+ :ucs-2) ;; (#. +mysql-cs-coll-ujis-binary+ :unknown) (#. +mysql-cs-coll-geostd8-general-ci+ :us-ascii) ; punting for geostd8 (#. +mysql-cs-coll-geostd8-binary+ :us-ascii) ; punting for geostd8 (#. +mysql-cs-coll-latin1-spanish-ci+ :iso-8859-1) (#. +mysql-cs-coll-cp932-japanese-ci+ :cp932) (#. +mysql-cs-coll-cp932-binary+ :cp932) (#. +mysql-cs-coll-eucjpms-japanese-ci+ :eucjp) (#. +mysql-cs-coll-eucjpms-binary+ :eucjp) ;; (#. +mysql-cs-coll-cp1250-polish-ci+ :unknown) (#. +mysql-cs-coll-utf16-unicode-ci+ :utf-16) (#. +mysql-cs-coll-utf16-icelandic-ci+ :utf-16) (#. +mysql-cs-coll-utf16-latvian-ci+ :utf-16) (#. +mysql-cs-coll-utf16-romanian-ci+ :utf-16) (#. +mysql-cs-coll-utf16-slovenian-ci+ :utf-16) (#. +mysql-cs-coll-utf16-polish-ci+ :utf-16) (#. +mysql-cs-coll-utf16-estonian-ci+ :utf-16) (#. +mysql-cs-coll-utf16-spanish-ci+ :utf-16) (#. +mysql-cs-coll-utf16-swedish-ci+ :utf-16) (#. +mysql-cs-coll-utf16-turkish-ci+ :utf-16) (#. +mysql-cs-coll-utf16-czech-ci+ :utf-16) (#. +mysql-cs-coll-utf16-danish-ci+ :utf-16) (#. +mysql-cs-coll-utf16-lithuanian-ci+ :utf-16) (#. +mysql-cs-coll-utf16-slovak-ci+ :utf-16) (#. +mysql-cs-coll-utf16-spanish2-ci+ :utf-16) (#. +mysql-cs-coll-utf16-roman-ci+ :utf-16) (#. +mysql-cs-coll-utf16-persian-ci+ :utf-16) (#. +mysql-cs-coll-utf16-esperanto-ci+ :utf-16) (#. +mysql-cs-coll-utf16-hungarian-ci+ :utf-16) (#. +mysql-cs-coll-utf16-sinhala-ci+ :utf-16) (#. +mysql-cs-coll-utf16-german2-ci+ :utf-16) (#. +mysql-cs-coll-utf16-croatian-ci+ :utf-16) (#. +mysql-cs-coll-utf16-unicode-520-ci+ :utf-16) (#. +mysql-cs-coll-utf16-vietnamese-ci+ :utf-16) (#. +mysql-cs-coll-ucs2-unicode-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-icelandic-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-latvian-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-romanian-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-slovenian-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-polish-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-estonian-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-spanish-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-swedish-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-turkish-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-czech-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-danish-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-lithuanian-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-slovak-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-spanish2-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-roman-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-persian-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-esperanto-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-hungarian-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-sinhala-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-german2-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-croatian-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-unicode-520-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-vietnamese-ci+ :ucs-2) (#. +mysql-cs-coll-ucs2-general-mysql500-ci+ :ucs-2) (#. +mysql-cs-coll-utf32-unicode-ci+ :utf-32) (#. +mysql-cs-coll-utf32-icelandic-ci+ :utf-32) (#. +mysql-cs-coll-utf32-latvian-ci+ :utf-32) (#. +mysql-cs-coll-utf32-romanian-ci+ :utf-32) (#. +mysql-cs-coll-utf32-slovenian-ci+ :utf-32) (#. +mysql-cs-coll-utf32-polish-ci+ :utf-32) (#. +mysql-cs-coll-utf32-estonian-ci+ :utf-32) (#. +mysql-cs-coll-utf32-spanish-ci+ :utf-32) (#. +mysql-cs-coll-utf32-swedish-ci+ :utf-32) (#. +mysql-cs-coll-utf32-turkish-ci+ :utf-32) (#. +mysql-cs-coll-utf32-czech-ci+ :utf-32) (#. +mysql-cs-coll-utf32-danish-ci+ :utf-32) (#. +mysql-cs-coll-utf32-lithuanian-ci+ :utf-32) (#. +mysql-cs-coll-utf32-slovak-ci+ :utf-32) (#. +mysql-cs-coll-utf32-spanish2-ci+ :utf-32) (#. +mysql-cs-coll-utf32-roman-ci+ :utf-32) (#. +mysql-cs-coll-utf32-persian-ci+ :utf-32) (#. +mysql-cs-coll-utf32-esperanto-ci+ :utf-32) (#. +mysql-cs-coll-utf32-hungarian-ci+ :utf-32) (#. +mysql-cs-coll-utf32-sinhala-ci+ :utf-32) (#. +mysql-cs-coll-utf32-german2-ci+ :utf-32) (#. +mysql-cs-coll-utf32-croatian-ci+ :utf-32) (#. +mysql-cs-coll-utf32-unicode-520-ci+ :utf-32) (#. +mysql-cs-coll-utf32-vietnamese-ci+ :utf-32) (#. +mysql-cs-coll-utf8-unicode-ci+ :utf-8) (#. +mysql-cs-coll-utf8-icelandic-ci+ :utf-8) (#. +mysql-cs-coll-utf8-latvian-ci+ :utf-8) (#. +mysql-cs-coll-utf8-romanian-ci+ :utf-8) (#. +mysql-cs-coll-utf8-slovenian-ci+ :utf-8) (#. +mysql-cs-coll-utf8-polish-ci+ :utf-8) (#. +mysql-cs-coll-utf8-estonian-ci+ :utf-8) (#. +mysql-cs-coll-utf8-spanish-ci+ :utf-8) (#. +mysql-cs-coll-utf8-swedish-ci+ :utf-8) (#. +mysql-cs-coll-utf8-turkish-ci+ :utf-8) (#. +mysql-cs-coll-utf8-czech-ci+ :utf-8) (#. +mysql-cs-coll-utf8-danish-ci+ :utf-8) (#. +mysql-cs-coll-utf8-lithuanian-ci+ :utf-8) (#. +mysql-cs-coll-utf8-slovak-ci+ :utf-8) (#. +mysql-cs-coll-utf8-spanish2-ci+ :utf-8) (#. +mysql-cs-coll-utf8-roman-ci+ :utf-8) (#. +mysql-cs-coll-utf8-persian-ci+ :utf-8) (#. +mysql-cs-coll-utf8-esperanto-ci+ :utf-8) (#. +mysql-cs-coll-utf8-hungarian-ci+ :utf-8) (#. +mysql-cs-coll-utf8-sinhala-ci+ :utf-8) (#. +mysql-cs-coll-utf8-german2-ci+ :utf-8) (#. +mysql-cs-coll-utf8-croatian-ci+ :utf-8) (#. +mysql-cs-coll-utf8-unicode-520-ci+ :utf-8) (#. +mysql-cs-coll-utf8-vietnamese-ci+ :utf-8) (#. +mysql-cs-coll-utf8-general-mysql500-ci+ :utf-8) (#. +mysql-cs-coll-utf8mb4-unicode-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-icelandic-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-latvian-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-romanian-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-slovenian-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-polish-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-estonian-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-spanish-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-swedish-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-turkish-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-czech-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-danish-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-lithuanian-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-slovak-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-spanish2-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-roman-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-persian-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-esperanto-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-hungarian-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-sinhala-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-german2-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-croatian-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-unicode-520-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb4-vietnamese-ci+ :utf-8) ; utf8mb4 (#. +mysql-cs-coll-utf8mb3-general-cs+ :utf8) )) qmynd-20170630-git/src/common/utilities.lisp000066400000000000000000000402111312441320500206430ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Scott McKay ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;; Optimized fixnum arithmetic (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter +optimize-default+ '(optimize (speed 1) (safety 3) (debug 3)) "Compiler optimization settings for safe, debuggable code.") (defparameter +optimize-fast-unsafe+ '(optimize (speed 3) (safety 0) (debug 0)) "Compiler optimization settings for fast, unsafe, hard-to-debug code.") ) ;eval-when (defmacro i+ (&rest fixnums) `(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n))))) (defmacro i- (number &rest fixnums) `(the fixnum (- (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n))))) (defmacro i* (&rest fixnums) `(the fixnum (* ,@(loop for n in fixnums collect `(the fixnum ,n))))) (defmacro i= (&rest fixnums) `(= ,@(loop for n in fixnums collect `(the fixnum ,n)))) (defmacro i< (&rest fixnums) `(< ,@(loop for n in fixnums collect `(the fixnum ,n)))) (defmacro i<= (&rest fixnums) `(<= ,@(loop for n in fixnums collect `(the fixnum ,n)))) (defmacro i> (&rest fixnums) `(> ,@(loop for n in fixnums collect `(the fixnum ,n)))) (defmacro i>= (&rest fixnums) `(>= ,@(loop for n in fixnums collect `(the fixnum ,n)))) (defmacro iash (value count) `(the fixnum (ash (the fixnum ,value) (the fixnum ,count)))) (defmacro ilogior (&rest fixnums) (if (cdr fixnums) `(the fixnum (logior (the fixnum ,(car fixnums)) ,(if (cddr fixnums) `(ilogior ,@(cdr fixnums)) `(the fixnum ,(cadr fixnums))))) `(the fixnum ,(car fixnums)))) (defmacro ilogand (&rest fixnums) (if (cdr fixnums) `(the fixnum (logand (the fixnum ,(car fixnums)) ,(if (cddr fixnums) `(ilogand ,@(cdr fixnums)) `(the fixnum ,(cadr fixnums))))) `(the fixnum ,(car fixnums)))) (define-modify-macro iincf (&optional (delta 1)) i+) (define-modify-macro idecf (&optional (delta 1)) i-) (defmacro ildb (bytespec value) `(the fixnum (ldb ,bytespec (the fixnum ,value)))) ;;; Managing symbols (defmacro with-gensyms ((&rest bindings) &body body) `(let ,(mapcar #'(lambda (b) `(,b (gensym ,(string b)))) bindings) ,@body)) (defun make-lisp-symbol (string) "Intern a string of the 'package:string' and return the symbol." (let* ((string (string string)) (colon (position #\: string)) (pkg (if colon (subseq string 0 colon) "KEYWORD")) (sym (if colon (subseq string (+ colon 1)) string))) (intern sym pkg))) (defun fintern (format-string &rest format-args) "Interns a new symbol in the current package." (declare (dynamic-extent format-args)) (intern (nstring-upcase (apply #'format nil format-string format-args)))) (defun kintern (format-string &rest format-args) "Interns a new symbol in the keyword package." (declare (dynamic-extent format-args)) (intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD")) (defun keywordify (x) "Given a symbol designator 'x', return a keyword whose name is 'x'. If 'x' is nil, this returns nil." (check-type x (or string symbol null)) (cond ((null x) nil) ((keywordp x) x) ((symbolp x) (keywordify (symbol-name x))) ((zerop (length x)) nil) ((string-not-equal x "nil") (intern (string-upcase x) (find-package "KEYWORD"))) (t nil))) ;;; with-prefixed-accessors (defmacro with-prefixed-accessors (names (prefix object) &body body) `(with-accessors (,@(loop for name in names collect `(,name ,(fintern "~A~A" prefix name)))) ,object ,@body)) ;;; Functional programming, please (defun curry (function &rest args) "Returns a function that applies 'function' to 'args', plus any additional arguments given at the call site." (if (and args (null (cdr args))) ;fast test for length = 1 (let ((arg (car args))) #'(lambda (&rest more-args) (apply function arg more-args))) #'(lambda (&rest more-args) (apply function (append args more-args))))) (define-compiler-macro curry (&whole form function &rest args &environment env) (declare (ignore env)) (if (and (listp function) (eq (first function) 'function) (symbolp (second function)) (and args (null (cdr args)))) `#'(lambda (&rest more-args) (apply ,function ,(car args) more-args)) form)) ;;; Decimal Parsing (defun parse-decimal (str) ;; Look into replacing this with a library. (assert (and (let ((x (aref str 0))) (or (char<= #\0 x #\9) (char= x #\-))) (every #'(lambda (x) (or (char<= #\0 x #\9) (char= x #\.))) (subseq str 1)) (< (count #\. str) 2))) (let ((start 0) (sign 1) found-decimal) (when (string-prefix-p "-" str) (setq start 1 sign -1)) (loop for i from start below (length str) for c = (aref str i) then (aref str i) for denominator = 0 then (if found-decimal (1+ denominator) denominator) if (char= c #\.) do (setq found-decimal t) else collect c into numerator finally (return (* sign (/ (parse-integer (coerce numerator 'string)) (expt 10 denominator))))))) (defun %denominator-divisible-by-2-or-5-only (x) "Helper function used in the definition of type DECIMAL-NUMBER. Return T if the denominator of x has only 2 and/or 5 as factors, otherwise return NIL." (let ((twos 0) (fives 0)) (values (or (zerop x) (let ((x (denominator x))) (loop while (evenp x) do (setq x (ash x -1)) (incf twos)) (loop with r = 0 while (and (> x 1) (zerop r)) do (multiple-value-setq (x r) (truncate x 5)) when (zerop r) do (incf fives) finally (return (zerop r))))) twos fives))) (defun write-decimal-to-string (value) ;; Collect factors (multiple-value-bind (decimalp twos fives) (%denominator-divisible-by-2-or-5-only value) (unless decimalp (error 'value-is-not-decimal :value value)) (let ((n (numerator value)) (d (denominator value))) ;; Adjust denominator (unless (= twos fives) (let ((multiple (expt (if (< twos fives) 2 5) (abs (- twos fives))))) (setf n (* n multiple) d (* d multiple)))) ;; Split into parts (multiple-value-bind (whole frac) (truncate (abs n) d) ;; Combine into string (apply #'concatenate 'string (when (minusp value) "-") (princ-to-string whole) (unless (zerop frac) `("." ,(princ-to-string frac)))))))) ;;; Portable floating point utilities #+(or abcl allegro ccl cmu sbcl lispworks) (defun single-float-bits (x) (declare (type single-float x)) #+abcl (system:single-float-bits x) #+allegro (multiple-value-bind (high low) (excl:single-float-to-shorts x) (declare (type (unsigned-byte 16) high low)) (logior (ash high 16) low)) #+ccl (ccl::single-float-bits x) #+cmu (kernel:single-float-bits x) #+sbcl (sb-kernel:single-float-bits x) #+lispworks (lispworks-float:single-float-bits x)) #-(or abcl allegro ccl cmu sbcl lispworks) (defun single-float-bits (x) (declare (type single-float x)) (assert (= (float-radix x) 2)) (if (zerop x) (if (eql x 0.0f0) 0 #x-80000000) (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) (integer-decode-float x) (assert (plusp lisp-significand)) (let* ((significand lisp-significand) (exponent (+ lisp-exponent 23 127)) (unsigned-result (if (plusp exponent) ;if not obviously denormalized (do () (nil) (cond ;; Special termination case for denormalized float number ((zerop exponent) ;; Denormalized numbers have exponent one greater than ;; in the exponent field (return (ash significand -1))) ;; Ordinary termination case ((>= significand (expt 2 23)) (assert (< 0 significand (expt 2 24))) ;; Exponent 0 is reserved for denormalized numbers, ;; and 255 is reserved for specials like NaN (assert (< 0 exponent 255)) (return (logior (ash exponent 23) (logand significand (1- (ash 1 23)))))) (t ;; Shift as necessary to set bit 24 of significand (setq significand (ash significand 1) exponent (1- exponent))))) (do () ((zerop exponent) ;; Denormalized numbers have exponent one greater than ;; the exponent field (ash significand -1)) (unless (zerop (logand significand 1)) (warn "Denormalized '~S' losing bits in ~D" 'single-float-bits x)) (setq significand (ash significand -1) exponent (1+ exponent)))))) (ecase lisp-sign ((1) unsigned-result) ((-1) (logior unsigned-result (- (expt 2 31))))))))) #+(or abcl allegro ccl cmu sbcl lispworks) (defun double-float-bits (x) (declare (type double-float x)) #+abcl (values (system:double-float-low-bits x) (system:double-float-high-bits x)) #+allegro (multiple-value-bind (us3 us2 us1 us0) (excl:double-float-to-shorts x) (logior (ash us1 16) us0) (logior (ash us3 16) us2)) #+ccl (multiple-value-bind (high low) (ccl::double-float-bits x) (values low high)) #+cmu (values (kernel:double-float-low-bits x) (kernel:double-float-high-bits x)) #+sbcl (values (sb-kernel:double-float-low-bits x) (sb-kernel:double-float-high-bits x)) #+lispworks (let ((bits (lispworks-float:double-float-bits x))) (values (logand #xffffffff bits) (ash bits -32)))) #-(or abcl allegro ccl cmu sbcl lispworks) (defun double-float-bits (x) (declare (type double-float x)) (assert (= (float-radix x) 2)) (if (zerop x) (if (eql x 0.0d0) 0 #x-8000000000000000) (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) (integer-decode-float x) (assert (plusp lisp-significand)) (let* ((significand lisp-significand) (exponent (+ lisp-exponent 52 1023)) (unsigned-result (if (plusp exponent) ;if not obviously denormalized (do () (nil) (cond ;; Special termination case for denormalized float number ((zerop exponent) ;; Denormalized numbers have exponent one greater than ;; in the exponent field (return (ash significand -1))) ;; Ordinary termination case ((>= significand (expt 2 52)) (assert (< 0 significand (expt 2 53))) ;; Exponent 0 is reserved for denormalized numbers, ;; and 2047 is reserved for specials like NaN (assert (< 0 exponent 2047)) (return (logior (ash exponent 52) (logand significand (1- (ash 1 52)))))) (t ;; Shift as necessary to set bit 53 of significand (setq significand (ash significand 1) exponent (1- exponent))))) (do () ((zerop exponent) ;; Denormalized numbers have exponent one greater than ;; the exponent field (ash significand -1)) (unless (zerop (logand significand 1)) (warn "Denormalized '~S' losing bits in ~D" 'double-float-bits x)) (setq significand (ash significand -1) exponent (1+ exponent)))))) (let ((result (ecase lisp-sign ((1) unsigned-result) ((-1) (logior unsigned-result (- (expt 2 63))))))) ;; Return the low bits and the high bits (values (logand #xffffffff result) (ash result -32))))))) #+(or abcl allegro ccl cmu sbcl lispworks) (defun make-single-float (bits) (declare (type (signed-byte 32) bits)) #+abcl (system:make-single-float bits) #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits) (ldb (byte 16 0) bits)) #+ccl (ccl::host-single-float-from-unsigned-byte-32 bits) #+cmu (kernel:make-single-float bits) #+sbcl (sb-kernel:make-single-float bits) #+lispworks (lispworks-float:make-single-float bits)) #-(or abcl allegro ccl cmu sbcl lispworks) (defun make-single-float (bits) (declare (type (signed-byte 32) bits)) (cond ;; IEEE float special cases ((zerop bits) 0.0) ((= bits #x-80000000) -0.0) (t (let* ((sign (ecase (ldb (byte 1 31) bits) (0 1.0) (1 -1.0))) (iexpt (ldb (byte 8 23) bits)) (exponent (if (zerop iexpt) ;denormalized -126 (- iexpt 127))) (mantissa (* (logior (ldb (byte 23 0) bits) (if (zerop iexpt) 0 (ash 1 23))) (expt 0.5 23)))) (* sign (expt 2.0 exponent) mantissa))))) #+(or abcl allegro ccl cmu sbcl lispworks) (defun make-double-float (low high) (declare (type (unsigned-byte 32) low) (type (signed-byte 32) high)) #+abcl (system:make-double-float (logior (ash high 32) low)) #+allegro (excl:shorts-to-double-float (ldb (byte 16 16) high) (ldb (byte 16 0) high) (ldb (byte 16 16) low) (ldb (byte 16 0) low)) #+ccl (ccl::double-float-from-bits (ilogand high #xffffffff) low) #+cmu (kernel:make-double-float high low) #+sbcl (sb-kernel:make-double-float high low) #+lispworks (lispworks-float:make-double-float high low)) #-(or abcl allegro ccl cmu sbcl lispworks) (defun make-double-float (low high) (declare (type (unsigned-byte 32) low) (type (signed-byte 32) high)) (cond ;; IEEE float special cases ((and (zerop high) (zerop low)) 0.0d0) ((and (= high #x-80000000) (zerop low)) -0.0d0) (t (let* ((bits (logior (ash high 32) low)) (sign (ecase (ldb (byte 1 63) bits) (0 1.0d0) (1 -1.0d0))) (iexpt (ldb (byte 11 52) bits)) (exponent (if (zerop iexpt) ;denormalized -1022 (- iexpt 1023))) (mantissa (* (logior (ldb (byte 52 0) bits) (if (zerop iexpt) 0 (ash 1 52))) (expt 0.5d0 52)))) (* sign (expt 2.0d0 exponent) mantissa))))) qmynd-20170630-git/src/mysql-protocol/000077500000000000000000000000001312441320500174555ustar00rootroot00000000000000qmynd-20170630-git/src/mysql-protocol/authentication.lisp000066400000000000000000000134511312441320500233710ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;; MYSQL Authentication Mechanisms ;;; MySQL v5.5.7 added a pluggable authentication mechanism. We don't ;;; support it yet, but there's no reason not to be ready for it. ;;; No plugin is equivalent to MySQL's default: mysql_native_password ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mysql_old_password (15.3.2) (defun mysql-weak-hash-password (password) ;; having that allows to support mysql servers without ;; +mysql-capability-client-long-password+ (if (null password) (make-array 8 :element-type '(unsigned-byte 8) :initial-element 32) (flet ((ub32 (i) (logand #xffffffff i)) (drop-sign-bit (i) (logand #x7fffffff i))) (let ((nr #x50305735) (nr2 #x12345671) (add 7)) (loop for c across (typecase password (string (babel:string-to-octets password :encoding :ascii)) (t password)) do (progn (setf nr (ub32 (logxor nr (+ (* (+ (logand nr #x3f) add) c) (ash nr 8)))) nr2 (ub32 (+ nr2 (logxor (ash nr2 8) nr))) add (+ add c)))) (ironclad:integer-to-octets (logior (ash (drop-sign-bit nr) 32) (drop-sign-bit nr2))))))) (defstruct mysql-rand-st max-value max-value-dbl seed1 seed2) (defun mysql-old-random-init (seed1 seed2) (let ((max-value #x3FFFFFFF)) (make-mysql-rand-st :max-value max-value :max-value-dbl (* 1.0d0 max-value) :seed1 (mod seed1 max-value) :seed2 (mod seed2 max-value)))) (defun my-rnd (rand-st) (setf (mysql-rand-st-seed1 rand-st) (mod (+ (* 3 (mysql-rand-st-seed1 rand-st)) (mysql-rand-st-seed2 rand-st)) (mysql-rand-st-max-value rand-st)) (mysql-rand-st-seed2 rand-st) (mod (+ 33 (mysql-rand-st-seed1 rand-st) (mysql-rand-st-seed2 rand-st)) (mysql-rand-st-max-value rand-st))) (/ (mysql-rand-st-seed1 rand-st) (mysql-rand-st-max-value-dbl rand-st))) (defun mysql-old-password-auth-response (password auth-data) "Scramble password hash with first 8 bytes of auth-data." (let* ((password-hash (mysql-weak-hash-password password)) (message-hash (mysql-weak-hash-password (subseq auth-data 0 8))) (rand-st (mysql-old-random-init (logxor (ironclad:octets-to-integer password-hash :end 4) (ironclad:octets-to-integer message-hash :end 4)) (logxor (ironclad:octets-to-integer password-hash :start 4) (ironclad:octets-to-integer message-hash :start 4)))) (scrambled (make-array 8 :element-type '(unsigned-byte 8)))) (loop for i below 8 do (setf (aref scrambled i) (+ 64 (floor (* 31 (my-rnd rand-st)))))) (let ((extra (floor (* 31 (my-rnd rand-st))))) (loop for i below 8 do (setf (aref scrambled i) (logxor (aref scrambled i) extra)))) scrambled)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mysql_native_password (15.3.3) (defun mysql-native-password-auth-response (password auth-data) ;; (xor (sha1 password) ;; (sha1 (concatenate auth-data (sha1 (sha1 password))))) (if (null password) "" (let* ((password-octets (babel:string-to-octets password)) (hash-stage-1 (ironclad:digest-sequence :sha1 password-octets)) (hash-stage-2 (ironclad:digest-sequence :sha1 hash-stage-1))) (map-into hash-stage-1 #'logxor hash-stage-1 (let ((digester (ironclad:make-digest :sha1))) (ironclad:update-digest digester auth-data :end 20) (ironclad:update-digest digester hash-stage-2) (ironclad:produce-digest digester)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mysql_clear_password (15.3.4) (defun mysql-clear-password-auth-response (password) "This function implements the MySQL clear-text password authentication mechanism." (babel:string-to-octets password)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; authentication_windows_client (15.3.5) ;;; Not implemented ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; sha256_password (15.3.6) ;;; Not implemented ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Authentication mechanism dispatcher (defun generate-auth-response (password auth-data &optional plugin) (cond ((or (not plugin) (string= plugin "mysql_native_password")) (mysql-native-password-auth-response password auth-data)) ((string= plugin "mysql_old_password") (mysql-old-password-auth-response password auth-data)) ((string= plugin "mysql_clear_password") (mysql-clear-password-auth-response password)) (T (error (make-condition 'mysql-unsupported-authentication :plugin plugin))))) qmynd-20170630-git/src/mysql-protocol/connection.lisp000066400000000000000000000171721312441320500225150ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) (defvar *mysql-connection* nil "All API entry-points after connect take a mysql-connection argument and must bind *mysql-connection* to that connection for internal function use.") (defvar *mysql-encoding* nil "As it happens, it's quite easy to have data in an encoding known only by the application, and completely unknown by MySQL which will keep sending unrelated meta-data. Use this setting to force the Qmynd driver to be using the encoding you know your data is encoded with.") (defmacro with-mysql-connection ((c) &body body) `(let* ((*mysql-connection* ,c) (babel::*default-character-encoding* (mysql-connection-character-set *mysql-connection*))) ,@body)) (defclass mysql-base-connection () ((connected :type boolean :accessor mysql-connection-connected) (stream :initarg :stream :accessor mysql-connection-stream) (server-version :type (or string null) :accessor mysql-connection-server-version) (connection-id :type (or integer null) :accessor mysql-connection-connection-id) (capabilities :type integer :accessor mysql-connection-capabilities :initform (mysql-capabilities-supported)) (character-set :type keyword :accessor mysql-connection-character-set :initform :utf-8) ;:iso-8859-1) (mysql-cs-coll :type integer :accessor mysql-connection-cs-coll :initform +mysql-cs-coll-utf8-general-ci+) (status-flags :type (or integer null) :accessor mysql-connection-status-flags) (sequence-id :type integer :initform 0 :accessor mysql-connection-sequence-id) (auth-data :type (vector (unsigned-byte 8)) :accessor mysql-connection-auth-data) (auth-plugin :type (or string null) :accessor mysql-connection-auth-plugin) (default-schema :type (or string null) :initarg :default-schema :accessor mysql-connection-default-schema) (current-command :type (or integer null) :initform nil :accessor mysql-connection-current-command) ;; This is internal library state. It may be destructively modified by the library. (prepared-statements :type list :initform nil :accessor mysql-connection-prepared-statements)) (:documentation "The base class for all MySQL connections.")) (defgeneric mysql-connection-close-socket (connection) (:documentation "Close the MySQL connection's socket.")) (defclass mysql-inet-connection (mysql-base-connection) ((socket :type (or usocket:stream-usocket null) :initarg :socket :accessor mysql-connection-socket)) (:documentation "An AF_INET MySQL connections.")) (defmethod mysql-connection-close-socket ((c mysql-inet-connection)) (usocket:socket-close (mysql-connection-socket c)) (setf (mysql-connection-connected *mysql-connection*) nil)) #+(or ccl sbcl ecl) (progn (defclass mysql-local-connection (mysql-base-connection) ((socket :initarg :socket :accessor mysql-connection-socket)) (:documentation "An AF_LOCAL MySQL connection.")) (defmethod mysql-connection-close-socket ((c mysql-local-connection)) (let ((socket (mysql-connection-socket c))) #+ccl (ccl::close socket) #+(or sbcl ecl) (sb-bsd-sockets:socket-close socket) ) (setf (mysql-connection-connected *mysql-connection*) nil)) ) ; progn (defmethod mysql-connection-remove-stale-prepared-statements ((c mysql-base-connection)) "Removes from C all prepared statements that do not have C as their connection." (setf (mysql-connection-prepared-statements *mysql-connection*) (delete-if-not #'(lambda (ps) (eq (mysql-prepared-statement-connection ps) *mysql-connection*)) (mysql-connection-prepared-statements *mysql-connection*)))) ;;; Flag utilities (defun flagsp (bits-to-test bits-available &optional (mode :every)) (ecase mode (:every (= bits-to-test (logand bits-to-test bits-available))) (:some (not (zerop (logand bits-to-test bits-available)))) (:notany (zerop (logand bits-to-test bits-available))))) (defmethod mysql-connection-has-status ((c mysql-base-connection) status-bits) (flagsp status-bits (mysql-connection-status-flags c))) (defmethod mysql-connection-has-capability ((c mysql-base-connection) cap-bits) (flagsp cap-bits (mysql-connection-capabilities c))) (defmethod mysql-connection-has-some-capability ((c mysql-base-connection) cap-bits) (flagsp cap-bits (mysql-connection-capabilities c) :some)) (defun mysql-has-capability (cap-bits) (mysql-connection-has-capability *mysql-connection* cap-bits)) (defun mysql-has-some-capability (cap-bits) (mysql-connection-has-some-capability *mysql-connection* cap-bits)) (defun mysql-add-required-capability (cap-bits) (setf (mysql-connection-capabilities *mysql-connection*) (logand (mysql-connection-capabilities *mysql-connection*) cap-bits))) ;;; Packet utilities (defmethod mysql-connection-write-packet ((c mysql-base-connection) payload) "Write PAYLOAD to C's stream as a wire packet." (setf (mysql-connection-sequence-id c) (write-wire-packet (mysql-connection-stream c) payload :sequence-id (mysql-connection-sequence-id c))) (values)) (defmethod mysql-connection-read-packet ((c mysql-base-connection)) "Read a wire packet from C's stream." (multiple-value-bind (stream seq-id) (read-wire-packet (mysql-connection-stream c) :expected-sequence-id (mysql-connection-sequence-id c)) (setf (mysql-connection-sequence-id c) seq-id) stream)) (defmethod mysql-connection-command-init ((c mysql-base-connection) command) "Initialize connection for a new command. Resets sequence-id in underlying stream(s)." (let ((stream (mysql-connection-stream c))) (when (typep stream 'mysql-compressed-stream) (setf (mysql-compressed-stream-sequence-id stream) 0))) (setf (mysql-connection-sequence-id c) 0 (mysql-connection-current-command c) command)) (defun mysql-command-init (command) "Initialize the default MySQL connection for a new command. Resets sequence-id in underlying stream(s)." (mysql-connection-command-init *mysql-connection* command)) (defun mysql-current-command-p (command) "Tests to see if COMMAND is the current command of the default MySQL connection." (eq (mysql-connection-current-command *mysql-connection*) command)) (defun mysql-write-packet (payload) "Write PAYLOAD to the default MySQL connection's stream as a wire packet." (mysql-connection-write-packet *mysql-connection* payload)) (defun mysql-read-packet () "Read a wire packet from the default MySQL connection's stream." (mysql-connection-read-packet *mysql-connection*)) qmynd-20170630-git/src/mysql-protocol/define-packet.lisp000066400000000000000000000255071312441320500230560ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Packet Definition Macrology #|| Specs: slot-specifier ::= (slot-name [[slot-options]]) slot-name ::= symbol slot-options ::= {:bind boolean } | {:eof eof-action} | {:mysql-type parser-type-spec} | {:predicate form} | {:reduce λ α′ α → β) {:transform λ α → β} | {:transient boolean} | {:type type-specifier} | {:value form} parser-type-spec ::= (integer integer-size) | (string-type string-termination-spec) integer-size ::= octet-count | :lenenc octet-count - read this many octets :lenenc - read a length-encoded integer :lenenc-null-ok - read a length-encoded integer, allowing integer to be NULL. string-type ::= octets | string octets - '(vector (unsigned-byte 8)) string - shorthand for octets transformed with #'babel:octets-to-string. NB: this is separate from the :transform option. string-termination-spec ::= integer | :eof | :lenenc | :null | :null-eof integer - a specific length. :eof - read until the end of the packet. :lenenc - read a length-encoded integer first, then use that as the length. :lenenc-null-ok - read a length-encoded integer first; if not null then use that as the length. :null - read until a null octet is encountered. :null-eof - read until a null octet is encountered or we hit the end of the packet. Used to deal with a bug in some forms of the initial handshake packet. eof-action ::= :error | :end :error - default; end-of-file signaled :end - stop parsing packet and return collected data Bind - Bind the slot value to its name so later slots may use it. Predicate - The provided form must return non-nil for this slot to be parsed as described. Reduce - The parsed value is combined with a previously parsed value of the same name using the λ provided. The old value is passed as the first argument; the new value is passed as the second argument. Transform - The parsed value is transformed using the provided λ. Transient - The parsed value is not returned as a parsed value. It may be used internally if named. Value - If present, the value parsed for this slot is expected to be equal to the value of the form. The Lisp type specified by :TYPE may be omitted if it can be deduced from :MYSQL-TYPE. Generally, if :TRANSFORM or :REDUCE are specified, you should specify a :TYPE. Order of Operations: • Predicate • parse-from-stream • Transform • Value • Reduce • Bind ||# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Slot meta-data (defclass packet-slot () ((name :type symbol :initarg :name :reader packet-slot-name) (bind :type boolean :initarg :bind :initform t :accessor packet-slot-bind) (eof :type keyword :initarg :eof :initform :error :accessor packet-slot-eof) (predicate :initform nil :initarg :predicate :accessor packet-slot-predicate) (reduce :initform nil :initarg :reduce :accessor packet-slot-reduce) (transform :initform nil :initarg :transform :accessor packet-slot-transform) (transient :type boolean :initarg :transient :initform nil :accessor packet-slot-transient) (mysql-type :initarg :mysql-type :accessor packet-slot-mysql-type) (type :initarg :type :initform nil :accessor packet-slot-type) (value :initarg :value :initform nil :accessor packet-slot-value))) (defun parse-slot (slot-specifier) (destructuring-bind (slot-name &rest slot-properties) slot-specifier (apply #'make-instance 'packet-slot :name slot-name slot-properties))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Packet struct (defun emit-packet-slot-lisp-type (slotd optional) (destructuring-bind (mysql-type termination-spec) (packet-slot-mysql-type slotd) (cond ((packet-slot-type slotd)) (t (let ((base-type (ecase mysql-type (integer (cond ((typep termination-spec 'integer) `(integer 0 ,(1- (ash 1 (* 8 termination-spec))))) (t 'integer))) (octets '(vector (unsigned-byte 8))) (string 'string)))) (if (or optional (packet-slot-predicate slotd) (eq termination-spec :lenenc-or-null)) `(or ,base-type null) base-type)))))) (defun emit-packet-struct (struct-name slotds) `(defstruct ,struct-name ,@(loop for slotd in slotds for optional = (eq (packet-slot-eof slotd) :end) then (or optional (eq (packet-slot-eof slotd) :end)) unless (or (packet-slot-transient slotd) (member (packet-slot-name slotd) done)) collect `(,(packet-slot-name slotd) nil :type ,(emit-packet-slot-lisp-type slotd optional)) collect (packet-slot-name slotd) into done))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parser logic (defun emit-packet-parser-slot-reader (slotd stream locals) (destructuring-bind (mysql-type termination-spec) (packet-slot-mysql-type slotd) (ecase mysql-type (integer (cond ((or (typep termination-spec 'integer) (member termination-spec locals)) `(read-fixed-length-integer ,termination-spec ,stream)) ((eq termination-spec :lenenc) `(read-length-encoded-integer ,stream)) ((eq termination-spec :lenenc-null-ok) `(read-length-encoded-integer ,stream :null-ok t)) (t (error (make-condition 'bad-mysql-type-spec :text (format nil "Unexpected termination type for integer: ~A." termination-spec)))))) ((octets string) (let ((parser (cond ((or (typep termination-spec 'integer) (member termination-spec locals)) `(read-fixed-length-octets ,termination-spec ,stream)) (t (ecase termination-spec (:eof `(read-rest-of-packet-octets ,stream)) (:lenenc `(read-length-encoded-octets ,stream)) (:lenenc-null-ok `(read-length-encoded-octets ,stream :null-ok t)) (:null `(read-null-terminated-octets ,stream)) (:null-eof `(read-null-terminated-octets ,stream nil))))))) (if (eq mysql-type 'string) (with-gensyms (octets) `(let ((,octets ,parser)) (when ,octets (babel:octets-to-string ,octets)))) parser)))))) (defun emit-packet-parser-slot (parser-name slotd stream locals) (declare (ignorable parser-name)) (with-gensyms (value) (let ((body (emit-packet-parser-slot-reader slotd stream locals))) (when (packet-slot-transform slotd) (setf body `(funcall ,(packet-slot-transform slotd) ,body))) (when (packet-slot-value slotd) (setf body `(let ((,value ,body)) (assert (equal ,(packet-slot-value slotd) ,value)) ,value))) (when (packet-slot-reduce slotd) (setf body `(funcall ,(packet-slot-reduce slotd) ,(packet-slot-name slotd) ,body))) (when (packet-slot-bind slotd) (setf body `(setf ,(packet-slot-name slotd) ,body))) (when (packet-slot-predicate slotd) (setf body `(when ,(packet-slot-predicate slotd) ,body))) (when (eq (packet-slot-eof slotd) :end) (setf body `(handler-case ,body (end-of-file () (return-from ,parser-name (values)))))) body))) (defun emit-packet-parser (parser-name constructor-name slot-descriptors) (with-gensyms (stream #|local-bind-args|#) `(defun ,parser-name (,stream) (let (,@(loop for slotd in slot-descriptors unless (member (packet-slot-name slotd) done) when (packet-slot-bind slotd) collect (packet-slot-name slotd) collect (packet-slot-name slotd) into done)) (block ,parser-name ,@(loop for slotd in slot-descriptors collect (emit-packet-parser-slot parser-name slotd stream locals) when (packet-slot-bind slotd) collect (packet-slot-name slotd) into locals)) (,constructor-name ,@(loop for slotd in slot-descriptors unless (or (packet-slot-transient slotd) (member (packet-slot-name slotd) done)) collect (kintern "~A" (packet-slot-name slotd)) and collect (packet-slot-name slotd) collect (packet-slot-name slotd) into done)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Entry point macro (defmacro define-packet (name slots) (let ((parser-name (fintern "~A-~A" 'parse name)) (struct-name (fintern "~A-~A" name 'packet)) (struct-constructor (fintern "~A-~A-~A" 'make name 'packet)) (slot-descriptors (mapcar #'parse-slot slots))) `(progn ;; Define a struct to hold non-transient data (eval-when (:compile-toplevel :load-toplevel :execute) ,(emit-packet-struct struct-name slot-descriptors)) ;; Define a parser to parse a payload of this form and populate the struct ,(emit-packet-parser parser-name struct-constructor slot-descriptors) ;; Define a writer to generate a packet payload of this type from the struct #| Implement writer here (only needed for servers, not for mere clients) |# ;; ',name))) qmynd-20170630-git/src/mysql-protocol/handshake.lisp000066400000000000000000000343261312441320500223040ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Connection Phase Packets (15.2.5) (define-packet initial-handshake-v10 ((tag :mysql-type (integer 1) :value 10 :transient t :bind nil) (server-version :mysql-type (string :null)) (connection-id :mysql-type (integer 4)) (auth-data :mysql-type (octets 8)) (reserved :mysql-type (integer 1) :value 0 :transient t :bind nil) (capability-flags :mysql-type (integer 2) :type integer) ;; This is interesting: the packet may end here, or continue as follows. (character-set :mysql-type (integer 1) :eof :end) (status-flags :mysql-type (integer 2)) (capability-flags :mysql-type (integer 2) :transform #'(lambda (x) (ash x 16)) :reduce #'logior) ;; Strictly speaking, this is 0 unless +mysql-capability-client-plugin-auth+, but the field it is ;; used for has a length of at least 13. We're being slightly looser than the spec here, but it ;; should not be a problem. (auth-data-length :mysql-type (integer 1) :transform #'(lambda (x) (max (- x 8) 13)) :transient t) (reserved :mysql-type (integer 10) :transient t :bind nil) ; reserved for future use. (auth-data :mysql-type (octets auth-data-length) :predicate (flagsp +mysql-capability-client-secure-connection+ capability-flags) ;; can we simplify the transform? :reduce #'(lambda (x y) (concatenate '(vector (unsigned-byte 8)) x y))) (auth-plugin :mysql-type (string :null-eof) :predicate (flagsp +mysql-capability-client-plugin-auth+ capability-flags)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Server can send this packet to ask client to use another authentication ;;; method (define-packet auth-switch-request ((tag :mysql-type (integer 1) :value #xfe) (plugin-name :mysql-type (string :null)) (auth-plugin-data :mysql-type (string :eof)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Old Authentication Method Switch Request Packet consisting of a single ;;; 0xfe byte. It is sent by server to request client to switch to Old ;;; Password Authentication if CLIENT_PLUGIN_AUTH capability is not ;;; supported (by either the client or the server) (define-packet old-auth-switch-request ((tag :mysql-type (integer 1) :value #xfe))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Protocol::AuthSwitchResponse ;;; We don't receive that packet (not being the server), but it would look ;;; like the following: ;; (define-packet auth-switch-response ;; ((auth-plugin-response :mysql-type (string :eof)))) (defun send-auth-switch-response (auth-response) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-sequence auth-response s)))) (defun process-initial-handshake-v10 (stream) "Parse an INITIAL-HANDSHAKE-V10 Packet and populate the default MySQL connection." (let ((packet (parse-initial-handshake-v10 stream))) (setf (mysql-connection-server-version *mysql-connection*) (initial-handshake-v10-packet-server-version packet) (mysql-connection-connection-id *mysql-connection*) (initial-handshake-v10-packet-connection-id packet) (mysql-connection-capabilities *mysql-connection*) (logand (mysql-connection-capabilities *mysql-connection*) (initial-handshake-v10-packet-capability-flags packet)) ;; we receive the MySQL Server default character-set, which we ;; don't care much about as the next packet we're sending is going ;; to define the character set we actually use. ;; (mysql-connection-character-set *mysql-connection*) ;; (mysql-cs-coll-to-character-encoding ;; (initial-handshake-v10-packet-character-set packet)) ;; (mysql-connection-cs-coll *mysql-connection*) ;; (initial-handshake-v10-packet-character-set packet) (mysql-connection-status-flags *mysql-connection*) (initial-handshake-v10-packet-status-flags packet) (mysql-connection-auth-data *mysql-connection*) (initial-handshake-v10-packet-auth-data packet) (mysql-connection-auth-plugin *mysql-connection*) (initial-handshake-v10-packet-auth-plugin packet)) (unless (mysql-has-capability +mysql-capabilities-required+) (error 'mysql-insufficient-capabilities :server-flags (initial-handshake-v10-packet-capability-flags packet))) ;; asedeno-TODO: add optional logging/debugging functionality #+nil (format t "Auth Data: ~A~%~ Auth Plugin: ~A~%~ Server Capabilities: ~8,'0X~%~ Client Capabilities: ~8,'0X~%~ Combined Capabiltiies ~8,'0X~%~%" auth-data (babel:octets-to-string auth-plugin-name) capability-flags (mysql-capabilities-supported) (mysql-connection-capabilities *mysql-connection*)) (values))) (defun send-ssl-request-packet (verify) "Sends a MySQL SSL Connection Request Packet and begins SSL negotiation." (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-fixed-length-integer (mysql-connection-capabilities *mysql-connection*) 4 s) (write-fixed-length-integer #x1000000 4 s) (write-byte (mysql-connection-cs-coll *mysql-connection*) s) (write-fixed-length-integer 0 23 s))) ; 23 reserved octets ;; We may not have CL+SSL, in which case we'll never get to this function, ;; but we still want it to compile. (let ((stream (uiop/package:symbol-call :cl+ssl :make-ssl-client-stream (mysql-connection-stream *mysql-connection*)))) (when verify (uiop/package:symbol-call :cl+ssl :ssl-stream-check-verify stream)) (setf (mysql-connection-stream *mysql-connection*) stream))) ;; We won't receive a Handshake Response packet (being a client only, not a server), but it looks like this. ;; (define-packet handshake-response-v41 ;; ((capability-flags :mysql-type (integer 4)) ;; (max-packet-size :mysql-type (integer 4)) ;; (character-set :mysql-type (integer 1)) ;; (reserved :mysql-type (string 23) :transient t :bind nil) ;; (username :mysql-type (string :null)) ;; (auth-response-length ;; :mysql-type (integer :lenenc) ;; :predicate (flagsp +mysql-capability-client-plugin-auth-lenenc-client-data+ capability-flags) ;; :transient t) ;; (auth-response-length ;; :mysql-type (integer 1) ;; :predicate (and (flagsp +mysql-capability-client-secure-connection+ capability-flags) ;; (not (flagsp +mysql-capability-client-plugin-auth-lenenc-client-data+ capability-flags))) ;; :transient t) ;; (auth-response ;; :mysql-type (octets auth-response-length) ;; :predicate (flagsp +mysql-capability-client-secure-connection+ capability-flags)) ;; (auth-response ;; :mysql-type (octets :null) ;; :predicate (not (flagsp +mysql-capability-client-secure-connection+ capability-flags))) ;; (schema ;; :mysql-type (string :null) ;; :predicate (flagsp +mysql-capability-client-connect-with-db+ capability-flags)) ;; (auth-plugin ;; :mysql-type (string :null) ;; :predicate (flagsp +mysql-capability-client-plugin-auth+ capability-flags)) ;; ;; requires additional parsing ;; (client-capability-octets ;; :mysql-type (octets :lenenc) ;; :predicate (flagsp +mysql-capability-client-connect-attrs+ capability-flags)))) (defun send-handshake-response-41 (&key username auth-plugin auth-response database) "Send a MySQL Handshake Response v41 to the default MySQL connection." (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-fixed-length-integer (mysql-connection-capabilities *mysql-connection*) 4 s) (write-fixed-length-integer #x1000000 4 s) (write-byte (mysql-connection-cs-coll *mysql-connection*) s) (write-fixed-length-integer 0 23 s) ; 23 reserved octets (write-null-terminated-octets (babel:string-to-octets username :encoding (mysql-connection-character-set *mysql-connection*)) s) (cond ((mysql-has-capability +mysql-capability-client-plugin-auth-lenec-client-data+) (write-length-encoded-integer (length auth-response) s) (write-sequence auth-response s)) ((mysql-has-capability +mysql-capability-client-secure-connection+) (write-byte (length auth-response) s) (write-sequence auth-response s)) (T (write-null-terminated-octets auth-response s))) ;; If the bit is still set at this point, then we have a database schema to specify. (when (mysql-has-capability +mysql-capability-client-connect-with-db+) (write-null-terminated-octets (babel:string-to-octets database :encoding (mysql-connection-character-set *mysql-connection*)) s)) (when (mysql-has-capability +mysql-capability-client-plugin-auth+) (write-null-terminated-octets (babel:string-to-octets auth-plugin :encoding (mysql-connection-character-set *mysql-connection*)) s)) #+mysql-client-connect-attributes (when (mysql-has-capability +mysql-capability-client-connect-attrs+) ;; asedeno-TODO: When this is implemented, what sort of ;; attributes do we want to send? Are they hard-coded? Supplied ;; by the user? Both? Stored in the connection object? nil)))) (defun process-initial-handshake-payload (stream) "Initial handshake processing dispatch." (let ((protocol-version (peek-first-octet stream))) (case protocol-version (10 (process-initial-handshake-v10 stream)) (t (error (make-condition 'protocol-version-mismatch :version protocol-version)))))) (defun mysql-connect-do-handshake (connection username password database &key client-found-rows compress ssl ssl-verify) "Perform the MySQL Initial Handshake with CONNECTION." ;; Read a wire packet (let ((initial-handshake-payload (mysql-connection-read-packet connection))) (with-mysql-connection (connection) ;; if required, add the client-found-rows capability (when client-found-rows (mysql-add-required-capability +mysql-capability-client-found-rows+)) ;; Process Initial Handshake (process-initial-handshake-payload initial-handshake-payload) (unless database (setf (mysql-connection-capabilities connection) (logandc2 (mysql-connection-capabilities connection) +mysql-capability-client-connect-with-db+))) (unless compress (setf (mysql-connection-capabilities connection) (logandc2 (mysql-connection-capabilities connection) +mysql-capability-client-compress+))) ;; Deal with SSL (unless (eq ssl :unspecified) (cond ((and ssl (not (mysql-has-capability +mysql-capability-client-ssl+))) ;; SSL requested, but we don't have it. (error 'ssl-not-supported)) ((null ssl) ;; SSL explicitly disabled (setf (mysql-connection-capabilities connection) (logandc2 (mysql-connection-capabilities connection) +mysql-capability-client-ssl+))))) (when (mysql-has-capability +mysql-capability-client-ssl+) (send-ssl-request-packet ssl-verify)) ;; Prepare Auth Response (handler-case (with-prefixed-accessors (auth-data auth-plugin) (mysql-connection- connection) ;; Prepare Initial Response OR Close and Signal (send-handshake-response-41 :username username :auth-response (generate-auth-response password auth-data auth-plugin) :auth-plugin auth-plugin :database database) (let* ((packet (mysql-read-packet)) (auth-switch (= #xfe (peek-first-octet packet)))) (cond ((and auth-switch (= 1 (my-len packet))) ;; switch to old auth (let ((auth-plugin "mysql_old_password")) (send-auth-switch-response (generate-auth-response password auth-data auth-plugin)))) (auth-switch (let* ((new-auth (parse-auth-switch-request packet)) (auth-data (auth-switch-request-packet-auth-plugin-data new-auth)) (auth-plugin (auth-switch-request-packet-plugin-name new-auth))) (send-auth-switch-response (generate-auth-response password auth-data auth-plugin))))) ;; now read the read auth response ;; unless we got an auth-switch packet, we already have the response. (parse-response (if auth-switch (mysql-read-packet) packet)))) (mysql-base-error (e) (mysql-connection-close-socket connection) (error e))) ;; Enable compression if possible (when (mysql-has-capability +mysql-capability-client-compress+) (setf (mysql-connection-stream connection) (make-instance 'mysql-compressed-stream :stream (mysql-connection-stream connection)))) ;; force the resultset encoding to be what we asked for, nothing else (send-command-query "SET character_set_results = null;")) (setf (mysql-connection-connected connection) t) connection)) qmynd-20170630-git/src/mysql-protocol/prepared-statements/000077500000000000000000000000001312441320500234445ustar00rootroot00000000000000qmynd-20170630-git/src/mysql-protocol/prepared-statements/binary-protocol-encoding.lisp000066400000000000000000000125371312441320500312540ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;; The parameter "column definition" does not specify types well enough to be used for encoding ;;; here. Instead, we'll pick an encoding based on the type of the parameter. Later we may allow the ;;; caller to override that type. (defun encode-binary-parameter (value value-stream type-stream) (flet ((encode-binary-integer (length) "Writes an n-octet integer to VALUE-STREAM and the type flags (signed vs unsigned) to TYPE-STREAM, assumes a type code has already been written to TYPE-STREAM." (assert (typep value 'integer)) (write-fixed-length-integer value length value-stream) (write-byte (if (minusp value) #x00 #x80) type-stream))) (etypecase value ;; Octets ((vector (unsigned-byte 8)) (write-length-encoded-octets value value-stream) (write-byte +mysql-type-var-string+ type-stream) (write-byte #x00 type-stream)) ;; Strings (→ octets) (string (encode-binary-parameter (babel:string-to-octets value) value-stream type-stream)) ;; Integers ;; tiny, signed or unsigned ((or bit (integer #x-80 #xff)) (write-byte +mysql-type-tiny+ type-stream) (encode-binary-integer 1)) ;; short, signed or unsigned ((integer #x-8000 #xffff) (write-byte +mysql-type-short+ type-stream) (encode-binary-integer 2)) ;; long, signed or unsigned ((integer #x-80000000 #xffffffff) (write-byte +mysql-type-long+ type-stream) (encode-binary-integer 4)) ;; long-long, signed or unsigned ((integer #x-8000000000000000 #xffffffffffffffff) (write-byte +mysql-type-longlong+ type-stream) (encode-binary-integer 8)) ;; too big, encode as string and let MySQL deal with it. (integer (encode-binary-parameter (princ-to-string value) value-stream type-stream)) ;; Ratios (→ Decimal String if possible, else Double) (ratio (handler-case (encode-binary-parameter (write-decimal-to-string value) value-stream type-stream) (value-is-not-decimal () (encode-binary-parameter (coerce value 'double-float) value-stream type-stream)))) ;; Floating point (single-float (write-fixed-length-integer (single-float-bits value) 4 value-stream) (write-byte +mysql-type-float+ type-stream) (write-byte #x80 type-stream)) (double-float (multiple-value-bind (l h) (double-float-bits value) (write-fixed-length-integer l 4 value-stream) (write-fixed-length-integer h 4 value-stream)) (write-byte +mysql-type-double+ type-stream) (write-byte #x80 type-stream)) ;; MySQL Date/Time structs (mysql-date-time (with-prefixed-accessors (year month day hour minute second microsecond) (mysql-date-time- value) (let ((length (cond ((= 0 year month day hour minute second microsecond) 0) ((= 0 hour minute second microsecond) 4) ((= 0 microsecond) 7) (t 11)))) (write-byte length value-stream) (when (> length 0) (write-fixed-length-integer year 2 value-stream) (write-byte month value-stream) (write-byte day value-stream)) (when (> length 4) (write-byte hour value-stream) (write-byte minute value-stream) (write-byte second value-stream)) (when (> length 7) (write-fixed-length-integer microsecond 4 value-stream)))) (write-byte +mysql-type-datetime+ type-stream) (write-byte 0 type-stream)) (mysql-time-interval (with-prefixed-accessors (negativep days hours minutes seconds microseconds) (mysql-time-interval- value) (let ((length (cond ((= 0 days hours minutes seconds microseconds) 0) ((= 0 microseconds) 8) (t 12)))) (write-byte length value-stream) (when (> length 0) (write-byte (if negativep 1 0) value-stream) (write-fixed-length-integer days 4 value-stream) (write-byte hours value-stream) (write-byte minutes value-stream) (write-byte seconds value-stream)) (when (> length 8) (write-fixed-length-integer microseconds 4 value-stream)))) (write-byte +mysql-type-time+ type-stream) (write-byte 0 type-stream)) (mysql-year (write-fixed-length-integer (mysql-year-year value) 2 value-stream) (write-byte +mysql-type-year+ type-stream) (write-byte 0 type-stream))))) qmynd-20170630-git/src/mysql-protocol/prepared-statements/prepared-statement.lisp000066400000000000000000000272371312441320500301540ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) (defclass mysql-prepared-statement () ((connection :type (or mysql-base-connection null) :initarg :connection :accessor mysql-prepared-statement-connection) (query-string :type string :initarg :query-string :accessor mysql-prepared-statement-query-string) (statement-id :type (unsigned-byte 32) :initarg :statement-id :accessor mysql-prepared-statement-statement-id) (columns :type (vector-of column-definition-v41-packet) :initarg :columns :accessor mysql-prepared-statement-columns) (parameters :type (vector-of column-definition-v41-packet) :initarg :parameters :accessor mysql-prepared-statement-parameters))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.7.4.1 command-statement-prepare ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-statement-prepare ;; ((tag :mysql-type (integer 1) :value +mysql-command-statement-prepare+ :transient t :bind nil) ;; (query-string :mysql-type (string :eof)))) (define-packet command-statement-prepare-ok ((status :mysql-type (integer 1) :value 0 :transient t :bind nil) (statement-id :mysql-type (integer 4)) (num-columns :mysql-type (integer 2)) (num-params :mysql-type (integer 2)) (reserved :mysql-type (integer 1) :transient t :bind nil) (warning-count :mysql-type (integer 2)))) (defun send-command-statement-prepare (query-string) (mysql-command-init +mysql-command-statement-prepare+) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-byte +mysql-command-statement-prepare+ s) (write-sequence (babel:string-to-octets query-string) s))) (let* ((my-stream (mysql-read-packet)) (tag (peek-first-octet my-stream))) (if (= tag +mysql-response-error+) (parse-response my-stream) (let* ((sp-ok (parse-command-statement-prepare-ok my-stream)) (parameter-count (command-statement-prepare-ok-packet-num-params sp-ok)) (column-count (command-statement-prepare-ok-packet-num-columns sp-ok)) (parameters (coerce (unless (zerop parameter-count) (loop repeat parameter-count collect (parse-column-definition-v41 (mysql-read-packet)) ;; Consume the EOF packet or signal an error for an ERR packet. finally (parse-response (mysql-read-packet)))) 'vector)) (columns (coerce (unless (zerop column-count) (loop repeat column-count collect (parse-column-definition-v41 (mysql-read-packet)) ;; Consume the EOF packet or signal an error for an ERR packet. finally (parse-response (mysql-read-packet)))) 'vector))) (let ((statement (make-instance 'mysql-prepared-statement :connection *mysql-connection* :query-string query-string :statement-id (command-statement-prepare-ok-packet-statement-id sp-ok) :columns columns :parameters parameters))) (push statement (mysql-connection-prepared-statements *mysql-connection*)) statement))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.7.5 command-statement-send-long-data ;;; This command is used to send TEXT and BLOB data outside of command-statement-execute. ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-statement-send-long-data ;; ((tag :mysql-type (integer 1) :value +mysql-command-statement-send-long-data+ :transient t :bind nil) ;; (statement-id :mysql-type (integer 4)) ;; (parameter-id :mysql-type (integer 2)) ;; (data :mysql-type (octets :eof)))) ;; There is no response to this command (defun send-command-statement-send-long-data (statement parameter-id data) (assert (typep parameter-id '(integer 0 #xffff))) (let ((octets (etypecase data ((vector (unsigned-byte 8)) data) (string (babel:string-to-octets data))))) (assert (eq *mysql-connection* (mysql-prepared-statement-connection statement))) (mysql-command-init +mysql-command-statement-send-long-data+) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-byte +mysql-command-statement-send-long-data+ s) (write-fixed-length-integer (mysql-prepared-statement-statement-id statement) 4 s) (write-fixed-length-integer parameter-id 2 s) (write-sequence octets s)))) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.7.6 command-statement-execute ;; We don't actually receive this packet as a client, but it looks like this. ;; This packet cannot be defined ahead of time anyhow. ;; (define-packet command-statement-execute ;; ((tag :mysql-type (integer 1) :value +mysql-command-statement-execute+ :transient t :bind nil) ;; (statement-id :mysql-type (integer 4)) ;; (flags :mysql-type (integer 1)) ;; ;; asedeno-TODO: add default value to define-packet slots ;; (iteration-count :mysql-type (integer 4)) ;; Always 1 ;; ;; NB: The length of the null bitmap is not defined without the context of a prepared statement. ;; (null-bitmap :mysql-type (octets n) :predicate (plusp n)) ;; (new-parameters :mysql-type (integer 1) :predicate (plusp n)) ;; (parameter-types :mysql-type (octets (* 2 n)) :predicate (= 1 new-parameters)) ;; ;; n values encoded in binary row protocol. ;; (values :mysql-type (octets :eof) :predicate (= 1 new-parameters)))) (defmethod send-command-statement-execute ((statement mysql-prepared-statement) &key parameters) (unless (member (length parameters) (list 0 (length (mysql-prepared-statement-parameters statement))) :test #'=) (error 'unexpected-parameter-count)) (assert (eq *mysql-connection* (mysql-prepared-statement-connection statement))) (mysql-command-init +mysql-command-statement-execute+) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-byte +mysql-command-statement-execute+ s) (write-fixed-length-integer (mysql-prepared-statement-statement-id statement) 4 s) ;; asedeno-TODO: Implement flags (write-byte 0 s) ;; Iteration count: always 1 (write-fixed-length-integer 1 4 s) (unless (zerop (length parameters)) (let ((parameters (coerce parameters 'vector)) (parameter-type-stream (flexi-streams:make-in-memory-output-stream :element-type '(unsigned-byte 8))) (parameter-stream (flexi-streams:make-in-memory-output-stream :element-type '(unsigned-byte 8))) (null-bitmap 0)) (unwind-protect (loop for i from 0 for parameter across parameters if parameter do (encode-binary-parameter parameter parameter-stream parameter-type-stream) else do (setf (ldb (byte 1 i) null-bitmap) 1) (write-byte +mysql-type-null+ parameter-type-stream) (write-byte 0 parameter-type-stream) end finally (write-fixed-length-integer null-bitmap (ceiling i 8) s) (let ((types (flexi-streams:get-output-stream-sequence parameter-type-stream))) (write-byte (if (zerop (length types)) 0 1) s) (write-sequence types s) (write-sequence (flexi-streams:get-output-stream-sequence parameter-stream) s))) (when parameter-type-stream (close parameter-type-stream)) (when parameter-stream (close parameter-stream))))))) (parse-command-statement-execute-response statement)) (defmethod parse-command-statement-execute-response ((statement mysql-prepared-statement)) (let* ((my-stream (mysql-read-packet)) (tag (peek-first-octet my-stream))) (if (member tag (list +mysql-response-ok+ +mysql-response-error+)) (parse-response my-stream) (let* ((column-count (parse-column-count my-stream)) (column-definitions (coerce (loop repeat column-count collect (parse-column-definition-v41 (mysql-read-packet)) ;; Consume the EOF packet or signal an error for an ERR packet. finally (parse-response (mysql-read-packet))) 'vector)) (rows (parse-binary-resultset-rows column-count column-definitions))) ;; The column definitions may have changed. (setf (mysql-prepared-statement-columns statement) column-definitions) (values rows column-definitions))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.7.7 command-statement-close ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-statement-close ;; ((tag :mysql-type (integer 1) :value +mysql-command-statement-close+ :transient t :bind nil) ;; (statement-id :mysql-type (integer 4)))) (defmethod send-command-statement-close ((statement mysql-prepared-statement)) (assert (eq *mysql-connection* (mysql-prepared-statement-connection statement))) (mysql-command-init +mysql-command-statement-close+) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-byte +mysql-command-statement-close+ s) (write-fixed-length-integer (mysql-prepared-statement-statement-id statement) 4 s))) ;; No response from server (setf (mysql-prepared-statement-connection statement) nil) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.7.8 command-statement-reset ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-statement-reset ;; ((tag :mysql-type (integer 1) :value +mysql-command-statement-reset+ :transient t :bind nil) ;; (statement-id :mysql-type (integer 4)))) ;; Returns OK or ERR packet (defmethod send-command-statement-reset ((statement mysql-prepared-statement)) (assert (eq *mysql-connection* (mysql-prepared-statement-connection statement))) (mysql-command-init +mysql-command-statement-reset+) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-byte +mysql-command-statement-reset+ s) (write-fixed-length-integer (mysql-prepared-statement-statement-id statement) 4 s))) (parse-response (mysql-read-packet))) (asdf-finalizers:final-forms) qmynd-20170630-git/src/mysql-protocol/response-packets.lisp000066400000000000000000000070121312441320500236340ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;; 15.1.3. Generic Response Packets (define-packet response-ok ((tag :mysql-type (integer 1) :value +mysql-response-ok+ :transient t :bind nil) (affected-rows :mysql-type (integer :lenenc)) (last-insert-id :mysql-type (integer :lenenc)) (status-flags :mysql-type (integer 2) :predicate (mysql-has-some-capability #.(logior +mysql-capability-client-protocol-41+ +mysql-capability-client-transactions+))) (warnings :mysql-type (integer 2) :predicate (mysql-has-capability +mysql-capability-client-protocol-41+)) (info :mysql-type (string :eof)))) (define-packet response-error ((tag :mysql-type (integer 1) :value +mysql-response-error+ :transient t :bind nil) (error-code :mysql-type (integer 2)) ;; This really a string, but we're just checking to see it's a #\# (state-marker :mysql-type (integer 1) :predicate (mysql-has-capability +mysql-capability-client-protocol-41+) :value #.(char-code #\#) :transient t :bind nil) (sql-state :mysql-type (string 5) :predicate (mysql-has-capability +mysql-capability-client-protocol-41+)) (error-message :mysql-type (string :eof)))) (define-packet response-end-of-file ((tag :mysql-type (integer 1) :value +mysql-response-end-of-file+ :transient t :bind nil) (warning-count :mysql-type (integer 2) :predicate (mysql-has-capability +mysql-capability-client-protocol-41+)) (status-flags :mysql-type (integer 2) :predicate (mysql-has-capability +mysql-capability-client-protocol-41+)))) (defun parse-response (stream) "Parse a generic (OK, ERR, EOF) packet. Update MySQL connection status flags as necessary." (declare (type my-packet-stream stream)) (let ((tag (peek-first-octet stream))) (cond ((= tag +mysql-response-ok+) (let ((packet (parse-response-ok stream))) (setf (mysql-connection-status-flags *mysql-connection*) (response-ok-packet-status-flags packet)) packet)) ((= tag +mysql-response-error+) (let ((packet (parse-response-error stream))) (error (make-condition 'mysql-error :code (response-error-packet-error-code packet) :message (response-error-packet-error-message packet) :state (response-error-packet-sql-state packet))))) ((= tag +mysql-response-end-of-file+) (let ((packet (parse-response-end-of-file stream))) (setf (mysql-connection-status-flags *mysql-connection*) (response-end-of-file-packet-status-flags packet)) packet)) (t (error (make-condition 'unexpected-packet :stream stream)))))) qmynd-20170630-git/src/mysql-protocol/response-result-set.lisp000066400000000000000000000437471312441320500243300ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.4.1 Text Resultset ;;; Two parts: ;;; • Column Definitions ;;; · Column Count (n) ;;; · Column Definition Packets (n total) ;;; · EOF Packet ;;; • Rows ;;; · One or more ResutltsetRow packets ;;; · EOF or ERR Packet ;;; If EOF packet status has +mysql-server-more-results-exist+ set, another ResultSet packet follows. ;;; (See +mysql-capability-client-multi-results+, +mysql-capability-client-ps-multi-results+.) ;; This packet is trivial and does not require a struct. ;; (define-packet column-count ;; ((count :mysql-type (integer :lenenc)))) (defun parse-column-count (stream) (read-length-encoded-integer stream)) (define-packet column-definition-v41 ((catalog :mysql-type (string :lenenc)) (schema :mysql-type (string :lenenc)) (table :mysql-type (string :lenenc)) (org-table :mysql-type (string :lenenc)) (name :mysql-type (string :lenenc)) (org-name :mysql-type (string :lenenc)) (len-fixed-fields :mysql-type (integer :lenenc) :value #x0c :transient t :bind nil) (cs-coll :mysql-type (integer 2)) (column-length :mysql-type (integer 4)) (type :mysql-type (integer 1)) (flags :mysql-type (integer 2)) (decimals :mysql-type (integer 1)) (filler :mysql-type (integer 2) :value 0 :transient t :bind nil) (default-value :mysql-type (string :lenenc-null-ok) :predicate (mysql-current-command-p +mysql-command-field-list+)))) (defun column-definition-type (column-definition) (column-definition-v41-packet-type column-definition)) (defun column-definition-encoding (column-definition) (mysql-cs-coll-to-character-encoding (column-definition-v41-packet-cs-coll column-definition))) (declaim (inline parse-text-protocol-result-column-as-text)) (defun parse-resultset-row (column-count column-definitions &key as-text result-type) "Parse a single row of the result set and return either a vector or a list, depending on the value of RESULT-TYPE. If AS-TEXT is t, return bare data from the server, still dealing with encoding of the text columns. The default for AS-TEXT is nil, in which case the result columns are parsed into native types depending on the meta data passed in COLUMNS-DEFINITIONS." (let* ((stream (mysql-read-packet)) (tag (peek-first-octet stream))) (labels ((parse-column (str column-definition) (when str (if as-text (parse-text-protocol-result-column-as-text str column-definition) (parse-text-protocol-result-column str column-definition)))) (result-as-vector (stream) (let ((row (make-array column-count :initial-element nil))) (loop for i fixnum from 0 below column-count for str = (read-length-encoded-octets stream :null-ok t) when str do (setf (aref row i) (parse-column str (aref column-definitions i)))) row)) (result-as-list (stream) (loop for i fixnum from 0 below column-count for str = (read-length-encoded-octets stream :null-ok t) collect (parse-column str (aref column-definitions i))))) (declare (inline parse-column result-as-vector result-as-list)) (cond ((or (and (= tag +mysql-response-end-of-file+) (< (my-len stream) 9)) (= tag +mysql-response-error+)) (parse-response stream)) (t (ecase result-type (vector (result-as-vector stream)) (list (result-as-list stream)))))))) (defun map-resultset-rows (fn column-count column-definitions &key as-text result-type) "Call the FN function with a single row from the result-set at a time. When RESULT-TYPE is list, the row is a list, when RESULT-TYPE is vector, the row passed to the FN function is a vector." (loop for row = (parse-resultset-row column-count column-definitions :as-text as-text :result-type result-type) until (typep row 'response-end-of-file-packet) do (funcall fn row))) (defun parse-resultset-rows (column-count column-definitions &key as-text result-type) "Accumulate the whole result set in memory then return it as a list or a vector depending on the value of RESULT-TYPE (a symbol)." (let ((rows (loop for row = (parse-resultset-row column-count column-definitions :as-text as-text :result-type result-type) until (typep row 'response-end-of-file-packet) collect row))) (coerce rows result-type))) (defun decode-octets-to-string (octets &optional encoding) "Decode the given vector of OCTETS into an internal Common Lisp string, given a known encoding for it. Provide a couple of restarts in case the decoding fails: - use-nil decode octets as a nil value - use-empty-string decode octets as an empty string (\"\") - use-value decode octets as any given value." (let ((encoding (or *mysql-encoding* encoding babel::*default-character-encoding*))) (restart-case (babel:octets-to-string octets :encoding encoding) (use-nil () :report "skip this column's value and use nil instead." nil) (use-empty-string () :report "skip this column's value and use and empty-string instead." "") (use-value (value) value)))) (defun parse-text-protocol-result-column-as-text (octets column-definition) "Refrain from parsing data into lisp types, some application will only use the text form anyway" (let ((column-type (column-definition-type column-definition))) (cond ((= column-type +mysql-type-null+) nil) ;; support for BLOB and TEXT types ((member column-type (list +mysql-type-tiny-blob+ +mysql-type-medium-blob+ +mysql-type-long-blob+ +mysql-type-blob+)) (if (= (column-definition-v41-packet-cs-coll column-definition) +mysql-cs-coll-binary+) octets (let ((encoding (column-definition-encoding column-definition))) (decode-octets-to-string octets encoding)))) ;; Binary types ((member column-type (list +mysql-type-bit+ +mysql-type-enum+ +mysql-type-set+ +mysql-type-geometry+) :test #'=) octets) ;; binary strings are strings with binary collations... ((and (member column-type (list +mysql-type-string+ +mysql-type-var-string+)) (= (column-definition-v41-packet-cs-coll column-definition) +mysql-cs-coll-binary+)) octets) (t (let ((encoding (column-definition-encoding column-definition))) (decode-octets-to-string octets encoding)))))) (defun parse-text-protocol-result-column (octets column-definition) (let ((column-type (column-definition-type column-definition)) str) (labels ((str () (unless str (setf str (decode-octets-to-string octets))) str) (parse-float (&optional (float-format 'single-float)) ;; Look into replacing this with a library, or moving it to utilities.lisp. (assert (every #'(lambda (x) (or (<= #.(char-code #\0) x #.(char-code #\9)) (member x (list #.(char-code #\-) #.(char-code #\e) #.(char-code #\.))))) octets)) (with-standard-io-syntax (let ((*read-default-float-format* float-format)) (with-input-from-string (s (str)) (read s)))))) (cond ;; Integers ((member column-type (list +mysql-type-tiny+ +mysql-type-short+ +mysql-type-long+ +mysql-type-longlong+ +mysql-type-int24+) :test #'=) (parse-integer (str))) ;; Decimals ((member column-type (list +mysql-type-decimal+ +mysql-type-newdecimal+) :test #'=) (parse-decimal (str))) ;; Floating Point ((= column-type +mysql-type-float+) (parse-float)) ((= column-type +mysql-type-double+) (parse-float 'double-float)) ;; Null ((= column-type +mysql-type-null+) nil) ;; Date/Time ((member column-type (list +mysql-type-timestamp+ +mysql-type-date+ +mysql-type-datetime+ +mysql-type-newdate+) :test #'=) (parse-date-time-string (str))) ((= column-type +mysql-type-year+) (make-instance 'mysql-year :year (parse-integer (str)))) ((= column-type +mysql-type-time+) (parse-time-interval-string (str))) ;; Strings and Binary Objects ((member column-type (list +mysql-type-varchar+ +mysql-type-var-string+ +mysql-type-string+ +mysql-type-bit+ +mysql-type-tiny-blob+ +mysql-type-medium-blob+ +mysql-type-long-blob+ +mysql-type-blob+) :test #'=) (let ((encoding (column-definition-encoding column-definition))) (cond (encoding (let ((babel::*default-character-encoding* encoding)) (str))) (t octets)))) ;; No idea how to parse and represent these yet ;; ((= column-type +mysql-type-enum+) ;; octets) ;; ((= column-type +mysql-type-set+) ;; octets) ;; ((= column-type +mysql-type-geometry+) ;; octets) (t ;; asedeno-TODO: log unknown type octets))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.7.1 Binary Protocol Resultset ;;; Two parts: ;;; • Column Definitions ;;; · Column Count (n) ;;; · Column Definition Packets (n total) ;;; · EOF Packet ;;; • Rows ;;; · Any number of BinaryResutltsetRow packets ;;; · EOF Packet (defun parse-binary-resultset-rows (column-count column-definitions) (flet ((parse-binary-resultset-row () (let* ((my-stream (mysql-read-packet)) (tag (peek-first-octet my-stream))) (cond ((or (and (= tag +mysql-response-end-of-file+) (< (my-len my-stream) 9)) (= tag +mysql-response-error+)) (parse-response my-stream)) ((= tag 0) (let ((s my-stream)) (read-fixed-length-octets 1 s) (let* ((row (make-array column-count :initial-element nil)) (null-bitmap (read-fixed-length-integer (ceiling (+ column-count 2) 8) s))) (loop for i from 0 below column-count when (zerop (ldb (byte 1 (+ i 2)) null-bitmap)) do (setf (aref row i) (parse-binary-protocol-result-column s (aref column-definitions i)))) row))) (t (error (make-condition 'unexpected-packet :payload (my-payload my-stream)))))))) (coerce (loop for row = (parse-binary-resultset-row) then (parse-binary-resultset-row) until (typep row 'response-end-of-file-packet) collect row) 'vector))) (defun parse-binary-protocol-result-column (stream column-definition) (let ((column-type (column-definition-type column-definition)) (encoding (column-definition-encoding column-definition))) (labels ((to-string (octets) (if encoding (decode-octets-to-string octets encoding) octets)) (parse-binary-integer (length) (read-fixed-length-integer length stream :signed (not (flagsp +mysql-flag-column-unsigned+ (column-definition-v41-packet-flags column-definition)))))) (cond ;; Stuff encoded as strings ((member column-type (list +mysql-type-varchar+ +mysql-type-bit+ +mysql-type-tiny-blob+ +mysql-type-medium-blob+ +mysql-type-blob+ +mysql-type-long-blob+ +mysql-type-var-string+ +mysql-type-string+) :test #'=) (let ((octets (read-length-encoded-octets stream))) (to-string octets))) ((member column-type (list +mysql-type-decimal+ +mysql-type-newdecimal+) :test #'=) (parse-decimal (to-string (read-length-encoded-octets stream)))) ;; Integers ((= column-type +mysql-type-longlong+) (parse-binary-integer 8)) ((member column-type (list +mysql-type-long+ +mysql-type-int24+) ;; Yes, 24-bit integers are transmitted as 32-bit integers. :test #'=) (parse-binary-integer 4)) ((= column-type +mysql-type-short+) (parse-binary-integer 2)) ((= column-type +mysql-type-tiny+) (parse-binary-integer 1)) ;; Floating Point ((= column-type +mysql-type-double+) (make-double-float (read-fixed-length-integer 4 stream) (read-fixed-length-integer 4 stream :signed t))) ((= column-type +mysql-type-float+) (make-single-float (read-fixed-length-integer 4 stream :signed t))) ;; Date/Time ((= column-type +mysql-type-year+) (let ((year (read-fixed-length-integer 2 stream))) (make-instance 'mysql-year :year year))) ((= column-type +mysql-type-time+) (let ((length (read-byte stream)) negativep (days 0) (h 0) (m 0) (s 0) (µs 0)) (assert (member length (list 0 8 12) :test #'=)) (when (>= length 8) (setf negativep (not (zerop (read-byte stream))) days (read-fixed-length-integer 4 stream) h (read-byte stream) m (read-byte stream) s (read-byte stream))) (when (>= length 12) (setf µs (read-fixed-length-integer 4 stream))) (make-instance 'mysql-time-interval :negativep negativep :days days :hours h :minutes m :seconds s :microseconds µs))) ((member column-type (list +mysql-type-timestamp+ +mysql-type-date+ +mysql-type-datetime+ +mysql-type-newdate+) :test #'=) (let ((length (read-byte stream)) (y 0) (m 0) (d 0) (hr 0) (mn 0) (s 0) (µs 0)) (assert (member length (list 0 4 7 11) :test #'=)) (when (>= length 4) (setf y (read-fixed-length-integer 2 stream) m (read-byte stream) d (read-byte stream))) (when (>= length 7) (setf hr (read-byte stream) mn (read-byte stream) s (read-byte stream))) (when (>= length 11) (setf µs (read-fixed-length-integer 4 stream))) (make-instance 'mysql-date-time :year y :month m :day d :hour hr :minute mn :second s :microsecond µs))) ((member column-type (list +mysql-type-enum+ +mysql-type-set+ +mysql-type-geometry+)) (read-rest-of-packet-octets stream)) ;; +mysql-type-null+ (encoded in null bitmap) (t ;; asedeno-TODO: log unknown type (read-rest-of-packet-octets stream)))))) qmynd-20170630-git/src/mysql-protocol/text-protocol/000077500000000000000000000000001312441320500223005ustar00rootroot00000000000000qmynd-20170630-git/src/mysql-protocol/text-protocol/command-change-user.lisp000066400000000000000000000076261312441320500270210ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.18 command-change-user ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-change-user ;; ((tag :mysql-type (integer 1) :value +mysql-command-change-user+ :transient t :bind nil) ;; (username :mysql-type (string :null)) ;; (auth-response-length ;; :mysql-type (integer 1) ;; :predicate (mysql-has-capability +mysql-capability-client-secure-connection+) ;; :transient t) ;; (auth-response ;; :mysql-type (string auth-response-length) ;; :predicate (mysql-has-capability +mysql-capability-client-secure-connection+)) ;; ;; This appears twice with different predicates. ;; (auth-response ;; :mysql-type (string :null) ;; :predicate (not (mysql-has-capability +mysql-capability-client-secure-connection+))) ;; (schema :mysql-type (string :null)) ;; (character-set :mysql-type (integer 2) :eof :end) ;; (auth-plugin :mysql-type (string :null) :eof :end))) (defun send-command-change-user (&key (username "") (password "") (schema "" schemap)) (flet ((reset-state () ;; Sending this command resets all prepared statements, so mark all known prepared statements as ;; invalid and drop them from the connection state. (mapc #'(lambda (ps) (setf (mysql-prepared-statement-connection ps) nil)) (mysql-connection-prepared-statements *mysql-connection*)) (setf (mysql-connection-prepared-statements *mysql-connection*) nil))) (mysql-command-init +mysql-command-change-user+) (with-prefixed-accessors (auth-data auth-plugin) (mysql-connection- *mysql-connection*) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (let ((auth-response (generate-auth-response password auth-data auth-plugin))) (write-byte +mysql-command-change-user+ s) (write-null-terminated-octets (babel:string-to-octets username) s) (cond ((mysql-has-capability +mysql-capability-client-secure-connection+) (let ((auth-response-length (length auth-response))) (assert (<= auth-response-length 255)) (write-byte auth-response-length s) (write-sequence auth-response s))) (t (write-null-terminated-octets auth-response s))) (write-null-terminated-octets (babel:string-to-octets schema) s) ;; Requires +mysql-capability-client-protocol-41+, which this library assumes is always set, (write-fixed-length-integer (mysql-connection-cs-coll *mysql-connection*) 2 s) (when (mysql-has-capability +mysql-capability-client-plugin-auth+) (write-null-terminated-octets (babel:string-to-octets auth-plugin) s))))) ;; Once the packet has been sent, do whatever state resetting we need to do. (reset-state) ;; asedeno-TODO: When we finally support +mysql-capability-client-plugin-auth+, we'll need to ;; deal with a possible Authentication Method Switch Response. ) (prog1 (parse-response (mysql-read-packet)) (setf (mysql-connection-default-schema *mysql-connection*) (when schemap schema)) (values)))) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-debug.lisp000066400000000000000000000022771312441320500257030ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.14 command-debug ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-debug ;; ((tag :mysql-type (integer 1) ;; :value +mysql-command-debug+ ;; :transient t :bind nil))) ;; Returns EOF or ERR packet (defun send-command-debug () (mysql-command-init +mysql-command-debug+) (mysql-write-packet (vector +mysql-command-debug+)) (parse-response (mysql-read-packet))) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-field-list.lisp000066400000000000000000000040571312441320500266470ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.5 command-field-list ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-field-list ;; ((tag :mysql-type (integer 1) ;; :value +mysql-command-field-list+ ;; :transient t :bind nil) ;; (table :mysql-type (string :null)) ;; (field-wildcard :mysql-type (string :eof)))) (defun send-command-field-list (table &optional field-wildcard) (mysql-command-init +mysql-command-field-list+) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-byte +mysql-command-field-list+ s) (write-null-terminated-octets (babel:string-to-octets table) s) (when field-wildcard (write-sequence (babel:string-to-octets field-wildcard) s)))) (let* ((initial-payload (mysql-read-packet)) (tag (aref initial-payload 0))) (if (= tag +mysql-response-error+) (parse-response initial-payload) (coerce (loop for payload = initial-payload then (mysql-read-packet) until (and (= (aref payload 0) +mysql-response-end-of-file+) (< (length payload) 9)) collect (parse-column-definition-v41 payload) ;; Consume the EOF packet or signal an error for an ERR packet. finally (parse-response payload)) 'vector)))) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-initialize-database.lisp000066400000000000000000000030421312441320500305070ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.3 command-initialize-database -- change the default schema ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-initialize-database ;; ((tag :mysql-type (integer 1) :value +mysql-command-initialize-database+ :transient t :bind nil) ;; (schema-name :mysql-type (string :eof)))) ;; Returns OK or ERR packet (defun send-command-initialize-database (schema-name) (mysql-command-init +mysql-command-initialize-database+) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-byte +mysql-command-initialize-database+ s) (write-sequence (babel:string-to-octets schema-name) s))) (prog1 (parse-response (mysql-read-packet)) (setf (mysql-connection-default-schema *mysql-connection*) schema-name))) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-ping.lisp000066400000000000000000000022611312441320500255430ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.15 command-ping ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-ping ;; ((tag :mysql-type (integer 1) ;; :value +mysql-command-ping+ ;; :transient t :bind nil))) ;; Returns OK packet (defun send-command-ping () (mysql-command-init +mysql-command-ping+) (mysql-write-packet (vector +mysql-command-ping+)) (parse-response (mysql-read-packet))) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-process-information.lisp000066400000000000000000000044441312441320500306140ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.11 command-process-info ;;; NB: This command is deprecated; use the query "SHOW PROCESSLIST" instead. ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-process-info ;; ((tag :mysql-type (integer 1) ;; :value +mysql-command-process-info+ ;; :transient t :bind nil))) ;; Returns Resultset or ERR packet (defun send-command-process-information () (mysql-command-init +mysql-command-process-information+) (mysql-write-packet (vector +mysql-command-process-information+)) (let* ((payload (mysql-read-packet)) (tag (aref payload 0))) (if (= tag +mysql-response-error+) (parse-response payload) (let* ((column-count (parse-column-count payload)) (column-definitions (coerce (loop repeat column-count collect (parse-column-definition-v41 (mysql-read-packet)) ;; Consume the EOF packet, or signal an error for an ERR packet. finally (parse-response (mysql-read-packet))) 'vector)) (rows (parse-resultset-rows column-count column-definitions))) (values rows column-definitions))))) #| ;; If COM_PROCESS_INFO ever gets disabled, compatability stub: ;; NB: this file will need to depend on command-process-query (defun send-command-process-information () (send-command-query "SHOW PROCESSLIST")) |# qmynd-20170630-git/src/mysql-protocol/text-protocol/command-process-kill.lisp000066400000000000000000000025461312441320500272230ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.13 command-process-kill ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-process-kill ;; ((tag :mysql-type (integer 1) ;; :value +mysql-command-process-kill+ ;; :transient t :bind nil) ;; (connection-id :mysql-type (integer 4)))) ;; Returns OK or ERR packet (defun send-command-process-kill (connection-id) (assert (typep connection-id '(unsigned-byte 32))) (mysql-command-init +mysql-command-process-kill+) (mysql-write-packet (vector +mysql-command-process-kill+ connection-id)) (parse-response (mysql-read-packet))) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-query.lisp000066400000000000000000000052611312441320500257560ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.4 command-query ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-query ;; ((tag :mysql-type (integer 1) :value +mysql-command-query+ :transient t :bind nil) ;; (query-string :mysql-type (string :eof)))) (defun send-command-query (query-string &key row-fn (as-text nil) (result-type 'vector)) "Send QUERY-STRING to the current MySQL connection. When the ROW-FN parameter is given, it must be a function and is called with each row as input, and the rows are discarded once the function is called. When AS-TEXT is t, the column values are not converted to native types and returned as text instead. By default the resultset is a vector of rows where each row is itself a vector of columns. When RESULT-TYPE is list, the result is a list of list of columns instead." (mysql-command-init +mysql-command-query+) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-byte +mysql-command-query+ s) (write-sequence (babel:string-to-octets query-string) s))) (let* ((my-stream (mysql-read-packet)) (tag (peek-first-octet my-stream))) (if (member tag (list +mysql-response-ok+ +mysql-response-error+)) (parse-response my-stream) (let* ((column-count (parse-column-count my-stream)) (column-definitions (coerce (loop repeat column-count collect (parse-column-definition-v41 (mysql-read-packet)) ;; Consume the EOF packet or signal an error for an ERR packet. finally (parse-response (mysql-read-packet))) 'vector)) (rows (if row-fn (map-resultset-rows row-fn column-count column-definitions :as-text as-text :result-type result-type) (parse-resultset-rows column-count column-definitions :as-text as-text :result-type result-type)))) (values rows column-definitions))))) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-quit.lisp000066400000000000000000000024361312441320500255740ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.2 command-quit ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-quit ;; ((tag :mysql-type (integer 1) ;; :value +mysql-command-quit+ ;; :transient t :bind nil))) ;; Closes connection or returns OK packet. (defun send-command-quit () (mysql-command-init +mysql-command-quit+) (mysql-write-packet (vector +mysql-command-quit+)) ;; Don't bother listening for the OK packet, just close the connection. (mysql-connection-close-socket *mysql-connection*)) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-refresh.lisp000066400000000000000000000024461312441320500262510ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.8 command-refresh ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-refresh ;; ((tag :mysql-type (integer 1) ;; :value +mysql-command-refresh+ ;; :transient t :bind nil) ;; (flags :mysql-type (integer 1)))) ;; Returns OK or ERR packet (defun send-command-refresh (flags) (assert (typep flags '(unsigned-byte 8))) (mysql-command-init +mysql-command-refresh+) (mysql-write-packet (vector +mysql-command-refresh+ flags)) (parse-response (mysql-read-packet))) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-shutdown.lisp000066400000000000000000000031001312441320500264520ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.9 command-shutdown ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-shutdown ;; ((tag :mysql-type (integer 1) ;; :value +mysql-command-shutdown+ ;; :transient t :bind nil) ;; ;; asedeno-TODO: add a default value to define-packet? ;; (flags :mysql-type (integer 1) :eof :end))) ;; Returns EOF or ERR packet (defun send-command-shutdown (&optional shutdown-type) (assert (typep shutdown-type '(or (unsigned-byte 8) null))) (mysql-command-init +mysql-command-shutdown+) (mysql-write-packet (flexi-streams:with-output-to-sequence (s) (write-byte +mysql-command-shutdown+ s) (when (and shutdown-type (not (= shutdown-type +mysql-shutdown-default+))) (write-byte shutdown-type s)))) (parse-response (mysql-read-packet))) qmynd-20170630-git/src/mysql-protocol/text-protocol/command-statistics.lisp000066400000000000000000000023411312441320500267770ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.6.10 command-statistics ;; We don't actually receive this packet as a client, but it looks like this. ;; (define-packet command-statistics ;; ((tag :mysql-type (integer 1) ;; :value +mysql-command-statistics+ ;; :transient t :bind nil))) ;; Returns (string :eof) (defun send-command-statistics () (mysql-command-init +mysql-command-statistics+) (mysql-write-packet (vector +mysql-command-statistics+)) (babel:octets-to-string (mysql-read-packet))) qmynd-20170630-git/src/pkgdcl.lisp000066400000000000000000000133501312441320500166100ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :cl-user) (defpackage qmynd (:use) (:export ;; Conditions / Errors #:mysql-base-error #:mysql-error #:mysql-insufficient-capabilities #:mysql-unsupported-authentication #:unexpected-packet #:value-is-not-decimal #:ssl-not-supported #:partial-read ;; Constants #:+mysql-server-status-in-transaction+ #:+mysql-server-status-autocommit+ #:+mysql-server-more-results-exist+ #:+mysql-server-status-no-good-index-used+ #:+mysql-server-status-no-index-used+ #:+mysql-server-status-cursor-exists+ #:+mysql-server-server-status-last-row-sent+ #:+mysql-server-status-database-dropped+ #:+mysql-server-status-no-backslash-escapes+ #:+mysql-server-status-metadata-changed+ #:+mysql-server-query-was-slow+ #:+mysql-server-ps-out-params+ ;; Opaque Structures #:mysql-base-connection #:mysql-prepared-statement ;; Transparent Structures #:mysql-date-time #:mysql-date-time-year #:mysql-date-time-month #:mysql-date-time-day #:mysql-date-time-hour #:mysql-date-time-minute #:mysql-date-time-second #:mysql-date-time-microsecond #:mysql-date-time-to-universal-time #:universal-time-to-mysql-date-time #:mysql-time-interval #:mysql-time-interval-negativep #:mysql-time-interval-days #:mysql-time-interval-hours #:mysql-time-interval-minutes #:mysql-time-interval-seconds #:mysql-time-interval-microseconds #:mysql-time-interval-to-seconds #:seconds-to-mysql-time-interval #:mysql-year #:mysql-year-year ;; API ;; Dynamic bindings #:*mysql-encoding* ;; Connections #:mysql-connect #+(or ccl sbcl ecl) #:mysql-local-connect #:mysql-disconnect #:mysql-connection-has-status #:mysql-connection-has-capability ;; Basic Commands #:mysql-query ;; Basic Response Packet Types / Accessors #:response-ok-packet #:response-ok-packet-affected-rows #:response-ok-packet-last-insert-id #:response-ok-packet-status-flags #:response-ok-packet-warnings ;; Prepared Statements #:mysql-statement-prepare #:mysql-statement-execute #:mysql-statement-close)) (defpackage qmynd-impl (:use :common-lisp :list-of :qmynd) (:import-from :uiop #:strcat #:string-prefix-p) (:export ;; Dynamic Variables #:*mysql-connection* #:*mysql-encoding* ;; Commands #:send-command-debug #:send-command-field-list #:send-command-initialize-database #:send-command-ping #:send-command-process-information #:send-command-process-kill #:send-command-query #:send-command-quit #:send-command-refresh #:send-command-shutdown #:send-command-statement-close #:send-command-statement-execute #:parse-command-statement-execute-response #:send-command-statement-prepare #:send-command-statement-reset #:send-command-statement-send-long-data #:send-command-statistics ;; Internal Helpers #:with-mysql-connection #:mysql-command-init #:mysql-has-capability #:mysql-has-some-capability #:mysql-connection-has-some-capability #:mysql-connection-stream #:mysql-current-command-p #:flagsp ;; Columnd defintion stuff #:column-definition-encoding #:column-definition-type ;; Resultset Parser #:parse-response #:parse-column-count #:parse-resultset-rows #:parse-text-protocol-result-column #:parse-binary-resultset-rows #:parse-binary-protocol-result-column ;; Prepared Statement Protocol #:encode-binary-parameter ;; Wire Protocol / Low-level connection #:mysql-read-packet #:mysql-write-packet #:mysql-connection-read-packet #:mysql-connection-write-packet ;; Initial Handshake: #:process-initial-handshake-payload #:process-initial-handshake-v10 #:send-handshake-response-41 ;; Auth Stuff #:generate-auth-response #+mysql-insecure-password-hash #:mysql-weak-hash-password #:mysql-native-password-auth-response #:mysql-clear-password-auth-response ;; Packet Definition Macrology and Related Functions #:define-packet #:packet-slot #:packet-slot-bind #:packet-slot-eof #:packet-slot-predicate #:packet-slot-reduce #:packet-slot-transform #:packet-slot-transient #:packet-slot-mysql-type #:packet-slot-type #:packet-slot-value #:parse-slot #:emit-packet-parser #:emit-packet-parser-slot #:emit-packet-parser-slot-reader #:emit-packet-slot-lisp-type #:emit-packet-struct ;; Accessors for user-opaque structures #:mysql-prepared-statement-connection #:mysql-prepared-statement-query-string #:mysql-prepared-statement-statement-id #:mysql-prepared-statement-columns #:mysql-prepared-statement-parameters #:mysql-connection-connected #:mysql-connection-socket #:mysql-connection-server-version #:mysql-connection-connection-id #:mysql-connection-capabilities #:mysql-connection-character-set #:mysql-connection-cs-coll #:mysql-connection-status-flags #:mysql-connection-sequence-id #:mysql-connection-auth-data #:mysql-connection-auth-plugin #:mysql-connection-default-schema #:mysql-connection-current-command #:mysql-connection-prepared-statements)) qmynd-20170630-git/src/wire-protocol/000077500000000000000000000000001312441320500172565ustar00rootroot00000000000000qmynd-20170630-git/src/wire-protocol/basic-types.lisp000066400000000000000000000242461312441320500224020ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;; asedeno-TODO: turn up compiler optimizations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.1.1.1. Integer ;;; 15.1.1.1.1. fixed length integer ;;; Little endian fixed-length integers with lengths (1 2 3 4 6 8) (define-compiler-macro read-fixed-length-integer (&whole form length stream &rest keys) (case length (1 (if keys `(read-1-octet-integer ,stream ,@keys) `(read-my-octet ,stream))) (2 `(read-2-octets-integer ,stream ,@keys)) (3 `(read-3-octets-integer ,stream ,@keys)) (4 `(read-4-octets-integer ,stream ,@keys)) (8 `(read-8-octets-integer ,stream ,@keys)) (10 `(read-10-octets-integer ,stream ,@keys)) (t form))) (defun read-fixed-length-integer (length stream &key signed) "Read an integer of LENGTH octets from STREAM." (ecase length (1 (read-my-octet stream)) (2 (read-2-octets-integer stream :signed signed)) (3 (read-3-octets-integer stream :signed signed)) (4 (read-4-octets-integer stream :signed signed)) (6 (read-6-octets-integer stream :signed signed)) (8 (read-8-octets-integer stream :signed signed)) (10 (read-10-octets-integer stream :signed signed)))) (declaim (inline unsigned-to-signed read-fixed-length-integer)) (defun unsigned-to-signed (byte n) (declare (type fixnum n) (type unsigned-byte byte)) (logior byte (- (mask-field (byte 1 (1- (* n 8))) byte)))) (defun read-1-octet-integer (stream &key signed) "Read 1 octet from STREAM as an integer." (declare (type my-packet-stream stream)) (let ((unsigned (read-my-octet stream))) (if signed (unsigned-to-signed unsigned 1) unsigned))) (defun read-2-octets-integer (stream &key signed) "Read 2 octets from STREAM as an integer." (declare (type my-packet-stream stream)) (let* ((octet-1 (read-my-octet stream)) (octet-2 (read-my-octet stream)) (unsigned (logior (ash octet-2 8) octet-1))) (if signed (unsigned-to-signed unsigned 2) unsigned))) (defun read-3-octets-integer (stream &key signed) (declare (type my-packet-stream stream)) (let* ((octet-1 (read-my-octet stream)) (octet-2 (read-my-octet stream)) (octet-3 (read-my-octet stream)) (unsigned (logior (ash octet-3 16) (ash octet-2 8) octet-1))) (if signed (unsigned-to-signed unsigned 3) unsigned))) (defun read-4-octets-integer (stream &key signed) (declare (type my-packet-stream stream)) (let* ((octet-1 (read-my-octet stream)) (octet-2 (read-my-octet stream)) (octet-3 (read-my-octet stream)) (octet-4 (read-my-octet stream)) (unsigned (logior (ash octet-4 24) (ash octet-3 16) (ash octet-2 8) octet-1))) (if signed (unsigned-to-signed unsigned 4) unsigned))) (defun read-6-octets-integer (stream &key signed) (declare (type my-packet-stream stream)) (let* ((octet-1 (read-my-octet stream)) (octet-2 (read-my-octet stream)) (octet-3 (read-my-octet stream)) (octet-4 (read-my-octet stream)) (octet-5 (read-my-octet stream)) (octet-6 (read-my-octet stream)) (unsigned (logior (ash octet-6 40) (ash octet-5 32) (ash octet-4 24) (ash octet-3 16) (ash octet-2 8) octet-1))) (if signed (unsigned-to-signed unsigned 6) unsigned))) (defun read-8-octets-integer (stream &key signed) (declare (type my-packet-stream stream)) (let* ((octet-1 (read-my-octet stream)) (octet-2 (read-my-octet stream)) (octet-3 (read-my-octet stream)) (octet-4 (read-my-octet stream)) (octet-5 (read-my-octet stream)) (octet-6 (read-my-octet stream)) (octet-7 (read-my-octet stream)) (octet-8 (read-my-octet stream)) (unsigned (logior (ash octet-8 56) (ash octet-7 48) (ash octet-6 40) (ash octet-5 32) (ash octet-4 24) (ash octet-3 16) (ash octet-2 8) octet-1))) (if signed (unsigned-to-signed unsigned 8) unsigned))) (defun read-10-octets-integer (stream &key signed) (declare (type my-packet-stream stream)) (let* ((octet-1 (read-my-octet stream)) (octet-2 (read-my-octet stream)) (octet-3 (read-my-octet stream)) (octet-4 (read-my-octet stream)) (octet-5 (read-my-octet stream)) (octet-6 (read-my-octet stream)) (octet-7 (read-my-octet stream)) (octet-8 (read-my-octet stream)) (octet-9 (read-my-octet stream)) (octet-10 (read-my-octet stream)) (unsigned (logior (ash octet-10 72) (ash octet-9 64) (ash octet-8 56) (ash octet-7 48) (ash octet-6 40) (ash octet-5 32) (ash octet-4 24) (ash octet-3 16) (ash octet-2 8) octet-1))) (if signed (unsigned-to-signed unsigned 10) unsigned))) (defun write-fixed-length-integer (int length stream) "Write INT to STREAM as a LENGTH byte integer." (loop repeat length for i fixnum from 0 by 8 do (write-byte (ldb (byte 8 i) int) stream))) ;;; 15.1.1.1.2. length encoded integer (defun read-length-encoded-integer (stream &key null-ok) "Read a MySQL Length-Encoded Integer from STREAM. Accepts the following keyword arguments: NULL-OK - Parse #xFB as NULL. Signals an error when we fail to parse an integer." (let ((n (read-my-octet stream))) (cond ((< n #xfb) n) ;; #xfb here is undefined, though it may mean NULL in certain contexts. ((and null-ok (= n #xfb)) nil) ((= n #xfc) (read-2-octets-integer stream)) ((= n #xfd) (read-3-octets-integer stream)) ((= n #xfe) (read-8-octets-integer stream)) ;; #xff here is undefined, though it may be an error packet in certain contexts. (t (error (make-condition 'invalid-length-encoded-integer :text "Bad length while reading a length-encoded integer.")))))) (defun write-length-encoded-integer (int stream) "Write INT to STREAM as a MySQL Length-Encoded Integer. Assumes INT is non-negative. Signals an error if INT is too big." (assert (not (minusp int))) (cond ((< int 251) (write-byte int stream)) ((< int #x10000) (write-byte #xfc stream) (write-fixed-length-integer int 2 stream)) ((< int #x1000000) (write-byte #xfd stream) (write-fixed-length-integer int 3 stream)) ((< int #x10000000000000000) (write-byte #xfe stream) (write-fixed-length-integer int 8 stream)) (t (error (make-condition 'invalid-length-encoded-integer :text (format nil "Integer ~A too large while length-encoding integer." int)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 15.1.1.2. MySQL String - A sequence of octets (not a Lisp string) ;;; NB: No character encoding/decoding is performed at this stage. ;;; Protocol::FixedLengthString ;;; A string with a known length (defun read-fixed-length-octets (length stream) "Read LENGTH octets from STREAM, returns them in a vector. NB: MySQL calls this a string, but we treat it as a vector of octets." (let ((octets (make-array length :element-type '(unsigned-byte 8) :initial-element 0))) (read-my-sequence octets stream) octets)) ;; Just use write-sequence directly ;; (defun write-string (octets stream) ;; (write-sequence octets stream)) ;;; Protocol::NulTerminatedString ;;; A string terminated by a NUL byte. (defun read-null-terminated-octets (stream &optional (eof-error-p t) &aux (length 16)) (declare (type my-packet-stream stream) (fixnum length)) (let ((octets (make-array length :element-type '(unsigned-byte 8) :initial-element 0 :adjustable t))) (loop for i fixnum from 0 as b fixnum = (read-my-octet stream eof-error-p (unless eof-error-p 0)) unless (< i length) do (incf length length) (setf octets (adjust-array octets length)) when (= b 0) return (adjust-array octets i) do (setf (aref octets i) b)))) (defun write-null-terminated-octets (octets stream) "Write OCTETS to STREAM followed by a NUL octet. Assumes no NUL octet exist in OCTETS." (assert (notany #'zerop octets)) (write-sequence octets stream) (write-byte 0 stream)) ;;; Protocol::VariableLengthString ;;; A string with a length determine by another field ;;; This will be implemented at a higher level using fixed-length-octets ;;; and knowledge of the other field. ;;; Protocol::LengthEncodedString ;;; A string prefixed by its length as a length-encoded integer (defun read-length-encoded-octets (stream &key null-ok) "Read a MySQL Length-Encoded Intgeer from STREAM, then read that many octets from STREAM. Accepts the following keyword arguments: NULL-OK: Allow READ-LENGTH-ENCODED-INTEGER to treat #xFB as NULL." (let ((length (read-length-encoded-integer stream :null-ok null-ok))) (when length (read-fixed-length-octets length stream)))) (defun write-length-encoded-octets (octets stream) "Write the length of OCTETS to STREAM as a MySQL Length-Encoded Integer, then write OCTETS to STREAM." (let ((length (length octets))) (write-length-encoded-integer length stream) (write-sequence octets stream))) ;;; For Protocol::RestOfPacketString, that just reads the rest of the packet, ;;; see function read-rest-of-packet-octets in wire-protocol/wire-packet.lisp. qmynd-20170630-git/src/wire-protocol/compressed-protocol.lisp000066400000000000000000000211741312441320500241570ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;; 5.4. Compression #| A MySQL Compressed Packet consists of: • 3 octets - length of packet (compressed) • 1 octet - sequence id (reset with, but independent of the wire-packet sequence-id) • 3 octets - length of packet (uncompressed); 0 means payload was not compressed • string[length] - the payload The MySQL Compression Protocol is independent of the MySQL Wire Protocol and is implemented here as a Gray stream that wraps the connection stream. The wrapping occurs after the MySQL Handshake is complete if compression is supported by the server and this library. This functionality depends on the CHIPZ (decompression) and SALZA2 (compression) libraries. NB: A future version of this library may support the Compression protocol using CHIPZ without SALZA, falling back on transmitting packets uncompressed, but for now using the Compression protocol requires both. |# ;;; Functions to read and write wire packets for the compressed protocol. (defun read-compressed-wire-packet (stream &key (expected-sequence-id 0)) "Read a compressed packet from STREAM." (let (payload (pos 0) (compressed-length (%read-3-octets stream)) (sequence-id (if (= (read-byte stream) expected-sequence-id) (setf expected-sequence-id (mod (1+ expected-sequence-id) 256)) (error (make-instance 'unexpected-sequence-id)))) (decompressed-length (%read-3-octets stream))) (assert (plusp compressed-length)) (setf payload (make-array compressed-length :element-type '(unsigned-byte 8))) (loop do (setf pos (read-sequence payload stream :start pos)) until (= pos (length payload))) (values (if (zerop decompressed-length) payload (let ((buffer (make-array decompressed-length :element-type '(unsigned-byte 8)))) (uiop/package:symbol-call :chipz :decompress buffer :zlib payload) buffer)) sequence-id))) (defun write-compressed-wire-packet (stream payload &key (sequence-id 0)) "Write PAYLOAD to STREAM as one or more compressed packets." (let* ((payload-length (length payload))) (flet ((send-payload (compressed-payload compressed-payload-length uncompressed-payload-length &key (start 0) end) (write-fixed-length-integer compressed-payload-length 3 stream) (write-byte sequence-id stream) (setf sequence-id (mod (1+ sequence-id) 256)) (write-fixed-length-integer uncompressed-payload-length 3 stream) (write-sequence compressed-payload stream :start start :end end)) (compress-payload (start end) (unless (typep payload '(simple-array (unsigned-byte 8) (*))) (setf payload (coerce payload '(simple-array (unsigned-byte 8) (*))))) (flexi-streams:with-output-to-sequence (buffer) (let ((compressor (make-instance (uiop/package:find-symbol* :zlib-compressor :salza2) :callback (lambda (octets end) (write-sequence octets buffer :end end))))) (uiop/package:symbol-call :salza2 :compress-octet-vector payload compressor :start start :end end) (uiop/package:symbol-call :salza2 :finish-compression compressor))))) (if (< payload-length +mysql-minimum-compression-length+) (send-payload payload payload-length 0) (loop for length from payload-length downto 0 by #xffffff for start from 0 by #xffffff for max-end from #xffffff by #xffffff for end = (min (+ start length) max-end) for compressed-payload = (compress-payload start end) for compressed-payload-length = (length compressed-payload) do (if (< payload-length compressed-payload-length) (send-payload payload payload-length 0 :start start :end end) (send-payload compressed-payload compressed-payload-length payload-length)))))) (force-output stream) sequence-id) ;;; Wrapper stream to implement the compressed protocol. (defclass mysql-compressed-stream (trivial-gray-streams:trivial-gray-stream-mixin trivial-gray-streams:fundamental-binary-input-stream trivial-gray-streams:fundamental-binary-output-stream) ((stream :initarg :stream :accessor mysql-compressed-stream-stream :documentation "The underlying stream.") (input-buffer :type (or flexi-streams:in-memory-input-stream null) :initform nil :accessor mysql-compressed-stream-input-buffer :documentation "The container for the incoming, just inflated, octet stream.") (output-buffer :type flexi-streams:in-memory-output-stream :initform (flexi-streams:make-in-memory-output-stream) :accessor mysql-compressed-stream-output-buffer :documentation "The container for the outgoing, to be deflated, octet stream.") (sequence-id :type integer :initform 0 :accessor mysql-compressed-stream-sequence-id :documentation "Sequence IDs for the compressed protocol packet stream."))) (defun fill-input-buffer (stream &aux payload) "Allocates a new input buffer stream from the results of parsing a new compressed packet off of the wrapped stream. Requires that the existing input buffer, if any, be empty." (assert (typep stream 'mysql-compressed-stream)) (with-accessors ((stream mysql-compressed-stream-stream) (input-buffer mysql-compressed-stream-input-buffer) (sequence-id mysql-compressed-stream-sequence-id)) stream (assert (null (and input-buffer (listen input-buffer)))) (multiple-value-setq (payload sequence-id) (read-compressed-wire-packet stream :expected-sequence-id sequence-id)) (when input-buffer (close input-buffer)) (setq input-buffer (flexi-streams:make-in-memory-input-stream payload)))) ;;; Gray Stream methods for our compressed stream. (defmethod trivial-gray-streams:stream-listen ((stream mysql-compressed-stream)) (with-accessors ((stream mysql-compressed-stream-stream) (input-buffer mysql-compressed-stream-input-buffer)) stream (or (when input-buffer (listen input-buffer)) (listen stream)))) (defmethod trivial-gray-streams:stream-read-byte ((stream mysql-compressed-stream)) (with-accessors ((input-buffer mysql-compressed-stream-input-buffer)) stream (unless (and input-buffer (listen input-buffer)) (fill-input-buffer stream)) (read-byte input-buffer))) (defmethod trivial-gray-streams:stream-read-sequence ((stream mysql-compressed-stream) sequence start end &key) (with-accessors ((input-buffer mysql-compressed-stream-input-buffer)) stream (unless (and input-buffer (listen input-buffer)) (fill-input-buffer stream)) (read-sequence sequence input-buffer :start start :end end))) (defmethod trivial-gray-streams:stream-write-byte ((stream mysql-compressed-stream) byte) (write-byte byte (mysql-compressed-stream-output-buffer stream))) (defmethod trivial-gray-streams:stream-write-sequence ((stream mysql-compressed-stream) sequence start end &key) (write-sequence sequence (mysql-compressed-stream-output-buffer stream) :start start :end end)) (defmethod trivial-gray-streams:stream-force-output ((stream mysql-compressed-stream)) (with-accessors ((stream mysql-compressed-stream-stream) (output-buffer mysql-compressed-stream-output-buffer) (sequence-id mysql-compressed-stream-sequence-id)) stream (setq sequence-id (write-compressed-wire-packet stream (flexi-streams:get-output-stream-sequence output-buffer) :sequence-id sequence-id)))) qmynd-20170630-git/src/wire-protocol/wire-packet.lisp000066400000000000000000000255371312441320500223760ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-impl) ;;; 15.1.2. MySQL Packet #| A MySQL Packet consists of: • 3 octets - length of packet • 1 octet - sequence id • string[length] - the payload 5.1.2.1. Big packets The largest packet is 2^24-1 octets long. If more data must be transmitted, a series of packets of length #xffffff are sent, with increasing sequence ids, until the remaining payload is less than 2^24-1 octets, at which point the remaining payload is transmitted with its actual size. This means that a packet of exactly 2^24-1 octets is transmitted as a full packet followed by a packet with a payload of 0 octets. 5.1.2.2. Sequence IDs The sequence_id is allowed to wrap. It is reset to 0 at the start of each Command Phase. |# ;;; ;;; The my-packet-stream class actually represents a chunk of the payload at ;;; a time, and its methods below know how to read from a packet and skip to ;;; the next chunk as needed. ;;; ;;; Each time we switch from a chunk to the next while reading the current ;;; packet, the slots of the my-stream instance are reset to whatever the ;;; next chunk properties are, including the chunk contents: we preload the ;;; payload octets. ;;; ;;; The methods are implemented as functions because we care enough about ;;; performances here to want to avoid the cost of CLOS dispatching. ;;; ;;; The main entry point to read data from the raw stream is ;;; read-wire-packet, which prepares a packet by reading its first chunk. ;;; ;;; The define-packet API and basic types implementation then fetch data ;;; from the stream by using the following low-level functions: ;;; ;;; - read-my-octet ;;; - peek-my-octet ;;; - read-my-sequence ;;; - read-rest-of-packet-octets ;;; ;;; Higher level functions such as read-fixed-length-integer or ;;; read-length-encoded-integer are defined in basic-types.lisp and build on ;;; this low-level API. ;;; (defconstant +max-packet-length+ #xffffff "Larger packet that we may receive, see https://dev.mysql.com/doc/internals/en/sending-more-than-16mbyte.html") (defvar *max-allowed-packets* #xffffff "Client side implementation of max_allowed_packets.") ;;; ;;; Each packet len and pos is an (integer 0 #xffffff), but when a value ;;; expands multiple packet read-my-sequence will append to the same ;;; my-packet-stream instance the whole content in a single payload ;;; sequence, thus len might be more than #xffffff. ;;; (defstruct (my-packet-stream (:conc-name my-)) (source nil :type (or null stream)) (payload nil :type (or null (simple-array (unsigned-byte 8) *))) (seq-id 0 :type (integer 0 255)) (len 0 :type integer) (pos 0 :type integer)) (defmethod print-object ((stream my-packet-stream) out) (print-unreadable-object (stream out :type t) (format out "~d/~d [~d]" (if (slot-boundp stream 'pos) (my-pos stream) "-") (if (slot-boundp stream 'len) (my-len stream) "-") (my-seq-id stream)))) (defun read-wire-packet (stream &key (expected-sequence-id 0)) "Instanciate a my-packet-stream object and read some meta-data about it." (let ((my-stream (make-my-packet-stream :source stream :seq-id expected-sequence-id))) ;; the next chunk is going to be the first one (prepare-next-chunk my-stream))) ;;; ;;; Low level protocol handling ;;; (declaim (inline %read-3-octets)) (defun %read-3-octets (stream) "Internal for wire protocol use only." (declare (type stream stream)) ;; As we don't have a proper my-packet-stream yet, we can't use ;; the usual read-3-octets-integer implementation. ;; We also know we are reading unsigned integer... (let ((octet-1 (read-byte stream)) (octet-2 (read-byte stream)) (octet-3 (read-byte stream))) (declare (type (unsigned-byte 8) octet-1 octet-2 octet-3)) (logior (ash octet-3 16) (ash octet-2 8) octet-1))) (defun prepare-next-chunk (my-stream) "Prepare reading from a new packet from our source stream." (let ((expected-sequence-id (my-seq-id my-stream))) (setf (my-len my-stream) (%read-3-octets (my-source my-stream)) (my-seq-id my-stream) (read-byte (my-source my-stream))) (assert (= expected-sequence-id (my-seq-id my-stream)) () 'unexpected-sequence-id) ;; prefetch this chunk of data, and reset the position (setf (my-payload my-stream) (read-whole-chunk (my-len my-stream) my-stream) (my-pos my-stream) 0) (setf (my-seq-id my-stream) (logand (1+ expected-sequence-id) #xFF)) (values my-stream (my-seq-id my-stream)))) ;;; ;;; Streaming API on top of the chunked packets protocol, automatically ;;; switch to next chunk as we read from the current packet. ;;; (declaim (inline maybe-read-next-chunk)) (defun maybe-read-next-chunk (stream &optional eof-error-p eof-value) "Check if we are at the end of the packet, or if we need to read from the next chunk from the network within the same \"logical\" packet." (declare (special *mysql-connection*)) (flet ((read-next-chunk () (prog1 (prepare-next-chunk stream) ;; we have to care about the connection sequence id here (setf (mysql-connection-sequence-id *mysql-connection*) (my-seq-id stream))))) (declare (inline read-next-chunk)) (cond ((= (my-pos stream) +max-packet-length+) (read-next-chunk)) ((= (my-pos stream) *max-allowed-packets*) (error "MySQL Packet too large: ~d is bigger than ~a bytes [~a]" (my-len stream) *max-allowed-packets* (my-pos stream))) ((= (my-pos stream) (my-len stream)) (if (< (my-len stream) +max-packet-length+) ;; no extra packet was needed (if eof-error-p (signal 'end-of-file) eof-value) ;; we reached the end of a +max-packet-length+ packet and need ;; to read from the next one now (read-next-chunk)))))) (defun read-my-octet (stream &optional eof-error-p eof-value) "Read a single octet from STREAM." (declare (type my-packet-stream stream)) ;; support for the peek-my-octet API (maybe-read-next-chunk stream eof-error-p eof-value) ;; now read a single octet from our source (prog1 (aref (my-payload stream) (my-pos stream)) (incf (my-pos stream)))) (defun peek-first-octet (stream) "Get the first octet in this stream's chunk." (aref (my-payload stream) 0)) (defun read-my-sequence (sequence stream) "Copy data from the STREAM into SEQUENCE." (declare (type my-packet-stream stream) (type (simple-array (unsigned-byte 8) (*)) sequence)) (if (<= (+ (length sequence) (my-pos stream)) (my-len stream)) ;; we already have the octets we're asked for, just grab'em (progn (replace sequence (my-payload stream) :start2 (my-pos stream)) (incf (my-pos stream) (length sequence))) ;; in that case we're going to cross at least a packet boundary (loop for pos fixnum from 0 below (length sequence) do (let* ((available-bytes (- (my-len stream) (my-pos stream))) (bytes (if (<= (+ pos available-bytes) (length sequence)) available-bytes (- (length sequence) pos)))) (replace sequence (my-payload stream) :start1 pos :start2 (my-pos stream) :end2 (+ (my-pos stream) bytes)) (incf (my-pos stream) bytes) (incf pos (- bytes 1)) (maybe-read-next-chunk stream))))) ;;; ;;; API to finish reading all remaining chunks of a packet ;;; (defun concatenate-vectors (length vectors) "Given a list of VECTORS containing LENGTH octets in total, return a single vector containing the same octets in the same order." (if (= 1 (length vectors)) (first vectors) (let ((vector (make-array length :element-type '(unsigned-byte 8)))) (loop for start = 0 then (+ start (length sub-vector)) for sub-vector in vectors do (replace vector (the (simple-array (unsigned-byte 8) (*)) sub-vector) :start1 start)) vector))) (defun read-whole-chunk (length stream) "Read LENGTH octets from STREAM and return an array of them." (declare (type my-packet-stream stream)) (let* ((vector (make-array length :element-type '(unsigned-byte 8))) (bytes (read-sequence vector (my-source stream)))) (unless (= bytes length) ;; This goes with MySQL server's log complaining: (Got timeout writing ;; communication packets). It looks like a MySQL bug and trying to ;; read the remaing bytes leads nowhere. (error (make-condition 'partial-read :bytes bytes :expected length))) (incf (my-pos stream) bytes) vector)) (defun read-rest-of-packet-octets (stream) "Copy the rest of the whole data set into an array and return it." (declare (type my-packet-stream stream)) (let* ((bytes-to-go (- (my-len stream) (my-pos stream))) (current-chunk-rest-bytes (make-array bytes-to-go :element-type '(unsigned-byte 8)))) (when (< 0 bytes-to-go) (read-my-sequence current-chunk-rest-bytes stream)) (loop for next-chunk = (maybe-read-next-chunk stream) while next-chunk collect (my-payload next-chunk) into vectors sum (my-len stream) into total-length finally (return (concatenate-vectors (+ bytes-to-go total-length) (cons current-chunk-rest-bytes vectors)))))) ;;; ;;; Write octets to the wire socket, as chunked packets. ;;; (defun write-wire-packet (stream payload &key (sequence-id 0)) "Write PAYLOAD to STREAM as one or more packets." (loop for length from (length payload) downto 0 by #xffffff for start from 0 by #xffffff for max-end from #xffffff by #xffffff for end = (min (+ start length) max-end) do (write-fixed-length-integer (- end start) 3 stream) do (write-byte sequence-id stream) do (setf sequence-id (mod (1+ sequence-id) 256)) do (write-sequence payload stream :start start :end end)) (force-output stream) sequence-id) qmynd-20170630-git/tests/000077500000000000000000000000001312441320500150245ustar00rootroot00000000000000qmynd-20170630-git/tests/basic-types.lisp000066400000000000000000000205111312441320500201370ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-test) (defmacro with-packet-input ((stream sequence) &body body) `(call-with-packet-input ,sequence (lambda (,stream) ,@body))) (defun call-with-packet-input (sequence fun) (funcall fun (qmynd-impl::make-my-packet-stream :source (flexi-streams:make-in-memory-input-stream ()) :payload (coerce sequence '(vector (unsigned-byte 8))) :seq-id 1 :pos 0 :len (length sequence)))) (define-test decode-fixed-length-integers () ;;prepare a stream with a bunch of integers for decoding (with-packet-input (s #(#x00 #x10 #x80 #xff #x00 #x00 #xfe #xff #x00 #x00 #x00 #xfd #xfe #xff #x00 #x00 #x00 #x00 #xfc #xfd #xfe #xff #x00 #x00 #x00 #x00 #x00 #x0 #xfa #xfb #xfc #xfd #xfe #xff #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x0 #xf8 #xf9 #xfa #xfb #xfc #xfd #xfe #xff #xff #x7f #x80 #x00 #xff #xff #xff #x7f #x00 #x80 #x00 #x00)) ;; 1 octet (assert-equal (read-fixed-length-integer 1 s) #x0) (assert-equal (read-fixed-length-integer 1 s) #x10) (assert-equal (read-fixed-length-integer 1 s) #x80) (assert-equal (read-fixed-length-integer 1 s) #xff) ;; 2 octet (assert-equal (read-fixed-length-integer 2 s) #x0) (assert-equal (read-fixed-length-integer 2 s) #xfffe) ;; 3 octet (assert-equal (read-fixed-length-integer 3 s) #x0) (assert-equal (read-fixed-length-integer 3 s) #xfffefd) ;; 4 octet (assert-equal (read-fixed-length-integer 4 s) #x0) (assert-equal (read-fixed-length-integer 4 s) #xfffefdfc) ;; 6 octet (assert-equal (read-fixed-length-integer 6 s) #x0) (assert-equal (read-fixed-length-integer 6 s) #xfffefdfcfbfa) ;; 8 octet (assert-equal (read-fixed-length-integer 8 s) #x0) (assert-equal (read-fixed-length-integer 8 s) #xfffefdfcfbfaf9f8) ;; Signed integers (assert-equal (read-fixed-length-integer 1 s :signed t) -1) (assert-equal (read-fixed-length-integer 1 s :signed t) 127) (assert-equal (read-fixed-length-integer 1 s :signed t) -128) (assert-equal (read-fixed-length-integer 1 s :signed t) 0) (assert-equal (read-fixed-length-integer 2 s :signed t) -1) (assert-equal (read-fixed-length-integer 2 s :signed t) 32767) (assert-equal (read-fixed-length-integer 2 s :signed t) -32768) (assert-equal (read-fixed-length-integer 2 s :signed t) 0))) (define-test encode-fixed-length-integers () (flet ((encode-test (int len expected) (assert-equal (flexi-streams:with-output-to-sequence (s) (write-fixed-length-integer int len s)) expected :test #'equalp))) ;; 1 octet (encode-test 0 1 #(0)) (encode-test #x10 1 #(#x10)) (encode-test #x80 1 #(#x80)) (encode-test #xff 1 #(#xff)) (encode-test -1 1 #(#xff)) (encode-test 127 1 #(#x7f)) ;; 1 octet fun with aliasing (encode-test 128 1 #(#x80)) (encode-test -128 1 #(#x80)) ;; 2 octet (encode-test 0 2 #(0 0)) (encode-test #xfffe 2 #(#xfe #xff)) (encode-test -1 2 #(#xff #xff)) ;; 3 octet (encode-test 0 3 #(0 0 0)) (encode-test #xfffefd 3 #(#xfd #xfe #xff)) ;; 4 octet (encode-test 0 4 #(0 0 0 0)) (encode-test #xfffefdfc 4 #(#xfc #xfd #xfe #xff)) ;; 6 octet (encode-test 0 6 #(0 0 0 0 0 0)) (encode-test #xfffefdfcfbfa 6 #(#xfa #xfb #xfc #xfd #xfe #xff)) ;; 8 octet (encode-test 0 8 #(0 0 0 0 0 0 0 0)) (encode-test #xfffefdfcfbfaf9f8 8 #(#xf8 #xf9 #xfa #xfb #xfc #xfd #xfe #xff)))) (define-test decode-length-encoded-integers () (with-packet-input (s #(#x0 #x80 #xfa #xfc #xfb #x0 #xfc #xfc #x0 #xfc #xfe #xff #xfd #xfd #xfe #xff #xfe #xf8 #xf9 #xfa #xfb #xfc #xfd #xfe #xff )) (assert-equal (read-length-encoded-integer s) #x0) (assert-equal (read-length-encoded-integer s) #x80) (assert-equal (read-length-encoded-integer s) #xfa) (assert-equal (read-length-encoded-integer s) #xfb) (assert-equal (read-length-encoded-integer s) #xfc) (assert-equal (read-length-encoded-integer s) #xfffe) (assert-equal (read-length-encoded-integer s) #xfffefd) (assert-equal (read-length-encoded-integer s) #xfffefdfcfbfaf9f8))) (define-test encode-length-encoded-integers () (flet ((encode-test (int expected) (assert-equal (flexi-streams:with-output-to-sequence (s) (write-length-encoded-integer int s)) expected :test #'equalp))) (encode-test #x00 #(#x00)) (encode-test #x80 #(#x80)) (encode-test #xfa #(#xfa)) (encode-test #xfb #(#xfc #xfb #x00)) (encode-test #xfc #(#xfc #xfc #x00)) (encode-test #xfffe #(#xfc #xfe #xff)) (encode-test #xfffefd #(#xfd #xfd #xfe #xff)) (encode-test #xfffefdfcfbfaf9f8 #(#xfe #xf8 #xf9 #xfa #xfb #xfc #xfd #xfe #xff)))) (define-test decode-strings () (let ((babel:*default-character-encoding* :utf-8)) ;; Preparing an octet stream with a bunch of strings in it. (with-packet-input (s (concatenate '(vector (unsigned-byte 8)) (babel:string-to-octets "Testing") #(13) (babel:string-to-octets "Hello, world!") (babel:string-to-octets "Hello") #(0) #(#xfc #xfb #x0) (make-array #xfb :element-type '(unsigned-byte 8) :initial-element #x41) (make-array #x100 :element-type '(unsigned-byte 8) :initial-element #x41) #(0) (babel:string-to-octets "Goodbye") #(0))) ;; Pull strings out of the stream. (assert-equal (babel:octets-to-string (read-fixed-length-octets 7 s)) "Testing" :test #'string=) (assert-equal (babel:octets-to-string (read-length-encoded-octets s)) "Hello, world!" :test #'string=) (assert-equal (babel:octets-to-string (read-null-terminated-octets s)) "Hello" :test #'string=) (let ((str (babel:octets-to-string (read-length-encoded-octets s)))) (assert-equal (length str) 251) (assert-true (every #'(lambda (x) (char= x #\A)) str))) (let ((str (babel:octets-to-string (read-null-terminated-octets s)))) (assert-equal (length str) 256) (assert-true (every #'(lambda (x) (char= x #\A)) str))) (assert-equal (babel:octets-to-string (read-null-terminated-octets s)) "Goodbye" :test #'string=)))) (define-test-suite mysql-basic-types-suite () (decode-fixed-length-integers encode-fixed-length-integers decode-length-encoded-integers encode-length-encoded-integers decode-strings)) (register-test 'mysql-basic-types-suite) qmynd-20170630-git/tests/binary-encoding.lisp000066400000000000000000000247131312441320500207740ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; NB: The unicode tests will fail if this file is not parsed as UTF-8. (in-package :qmynd-test) (defun sequence-equal (x y) ;; smooths over difference in type, fill-pointer, etc. (and (typep x 'sequence) (typep y 'sequence) (equal (coerce x 'list) (coerce y 'list)))) (defmacro generate-binary-encoding-test (value expected-value-encoding expected-type-encoding) `(generate-binary-encoding-test-helper ',value ,value ,expected-value-encoding ,expected-type-encoding)) (defun generate-binary-encoding-test-helper (value-form value expected-value-encoding expected-type-encoding) (let ((vs (flexi-streams:make-in-memory-output-stream :element-type '(unsigned-byte 8))) (ts (flexi-streams:make-in-memory-output-stream :element-type '(unsigned-byte 8)))) (unwind-protect (progn (encode-binary-parameter value vs ts) (assert-equal-helper `(binary-encoding ,value-form :value) (flexi-streams:get-output-stream-sequence vs) 'expected expected-value-encoding 'sequence-equal) (assert-equal-helper `(binary-encoding ,value-form :type) (flexi-streams:get-output-stream-sequence ts) 'expected expected-type-encoding 'sequence-equal)) (when vs (close vs)) (when ts (close ts))))) ;; Octets (define-test binary-encoding-octets-1 () (let ((octets (coerce #(0 1 2 3 127 128 255) '(vector (unsigned-byte 8))))) (generate-binary-encoding-test octets (concatenate '(vector (unsigned-byte 8)) #(7) octets) #(#.+mysql-type-var-string+ #x00)))) (define-test binary-encoding-octets-2 () (let ((octets (make-array 255 :element-type '(unsigned-byte 8) :initial-element 0))) (generate-binary-encoding-test octets (concatenate '(vector (unsigned-byte 8)) #(#xfc #xff #x00) octets) #(#.+mysql-type-var-string+ #x00)))) (define-test-suite binary-encoding-octets-suite () (binary-encoding-octets-1 binary-encoding-octets-2)) ;; Strings (define-test binary-encoding-ascii-string () (generate-binary-encoding-test "Hello, World!" #(13 72 101 108 108 111 44 32 87 111 114 108 100 33) #(#.+mysql-type-var-string+ #x00))) (define-test binary-encoding-unicode-string () (generate-binary-encoding-test "拝啓" ;; U+62DD U+5553, just for some unicode testing #(6 230 139 157 229 149 147) #(#.+mysql-type-var-string+ #x00))) (define-test binary-encoding-unicode-string-2 () (generate-binary-encoding-test "Sedeño" #(7 83 101 100 101 195 177 111) #(#.+mysql-type-var-string+ #x00))) (define-test binary-encoding-latin-1-string () (let ((babel::*default-character-encoding* :latin-1)) (generate-binary-encoding-test "Sedeño" #(6 83 101 100 101 241 111) #(#.+mysql-type-var-string+ #x00)))) (define-test-suite binary-encoding-string-suite () (binary-encoding-ascii-string binary-encoding-unicode-string binary-encoding-unicode-string-2 binary-encoding-latin-1-string)) ;; Integers (signed if negative) (define-test binary-encoding-tiny-1 () (generate-binary-encoding-test #x00 #(#x00) #(#.+mysql-type-tiny+ #x80))) (define-test binary-encoding-tiny-2 () (generate-binary-encoding-test #x80 #(#x80) #(#.+mysql-type-tiny+ #x80))) (define-test binary-encoding-tiny-3 () (generate-binary-encoding-test #xff #(#xff) #(#.+mysql-type-tiny+ #x80))) (define-test binary-encoding-tiny-4 () (generate-binary-encoding-test #x-80 #(#x80) #(#.+mysql-type-tiny+ #x00))) (define-test binary-encoding-tiny-5 () (generate-binary-encoding-test #x-01 #(#xff) #(#.+mysql-type-tiny+ #x00))) ;; short (define-test binary-encoding-short-1 () (generate-binary-encoding-test #x8000 #(#x00 #x80) #(#.+mysql-type-short+ #x80))) (define-test binary-encoding-short-2 () (generate-binary-encoding-test #xffff #(#xff #xff) #(#.+mysql-type-short+ #x80))) (define-test binary-encoding-short-3 () (generate-binary-encoding-test #x-8000 #(#x00 #x80) #(#.+mysql-type-short+ #x00))) ;; long (define-test binary-encoding-long-1 () (generate-binary-encoding-test #x80000000 #(#x00 #x00 #x00 #x80) #(#.+mysql-type-long+ #x80))) (define-test binary-encoding-long-2 () (generate-binary-encoding-test #xffffffff #(#xff #xff #xff #xff) #(#.+mysql-type-long+ #x80))) (define-test binary-encoding-long-3 () (generate-binary-encoding-test #x-80000000 #(#x00 #x00 #x00 #x80) #(#.+mysql-type-long+ #x00))) ;; long long (define-test binary-encoding-longlong-1 () (generate-binary-encoding-test #x8000000000000000 #(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80) #(#.+mysql-type-longlong+ #x80))) (define-test binary-encoding-longlong-2 () (generate-binary-encoding-test #xffffffffffffffff #(#xff #xff #xff #xff #xff #xff #xff #xff) #(#.+mysql-type-longlong+ #x80))) (define-test binary-encoding-longlong-3 () (generate-binary-encoding-test #x-8000000000000000 #(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80) #(#.+mysql-type-longlong+ #x00))) (define-test-suite binary-encoding-integer-suite () (binary-encoding-tiny-1 binary-encoding-tiny-2 binary-encoding-tiny-3 binary-encoding-tiny-4 binary-encoding-tiny-5 binary-encoding-short-1 binary-encoding-short-2 binary-encoding-short-3 binary-encoding-long-1 binary-encoding-long-2 binary-encoding-long-3 binary-encoding-longlong-1 binary-encoding-longlong-2 binary-encoding-longlong-3)) ;; Ratios ;; as decimals, which travel as length-encoded strings. (define-test binary-encoding-ratio-decimal-1 () (generate-binary-encoding-test (/ 102 10) #(4 #x31 #x30 #x2e #x32) #(#.+mysql-type-var-string+ #x00))) (define-test binary-encoding-ratio-decimal-2 () (generate-binary-encoding-test (/ -102 10) #(5 #x2d #x31 #x30 #x2e #x32) #(#.+mysql-type-var-string+ #x00))) ;; approximated as a double when not a decimal (define-test binary-encoding-ratio-double-1 () (generate-binary-encoding-test (/ 102 11) #(#x8C #x2E #xBA #xE8 #xA2 #x8B #x22 #x40) #(#.+mysql-type-double+ #x80))) (define-test binary-encoding-ratio-double-2 () (generate-binary-encoding-test (/ -102 11) #(#x8C #x2E #xBA #xE8 #xA2 #x8B #x22 #xC0) #(#.+mysql-type-double+ #x80))) (define-test-suite binary-encoding-ratio-suite () (binary-encoding-ratio-decimal-1 binary-encoding-ratio-decimal-2 binary-encoding-ratio-double-1 binary-encoding-ratio-double-2)) ;; Floating Point ;; single - expects lisp single-float to be encoded as 32-bit (define-test binary-encoding-float-1 () (generate-binary-encoding-test 10.2f0 #(#x33 #x33 #x23 #x41) #(#.+mysql-type-float+ #x80))) ;; double - expects lisp double-float to be encoded as 64-bit (define-test binary-encoding-double-1 () (generate-binary-encoding-test 10.2d0 #(#x66 #x66 #x66 #x66 #x66 #x66 #x24 #x40) #(#.+mysql-type-double+ #x80))) (define-test-suite binary-encoding-float-suite () (binary-encoding-float-1 binary-encoding-double-1)) ;; MySQL Date/Time Structs ;; Date-Time, at lengths 0, 4, 7, and 11 (define-test binary-encoding-datetime-1 () (generate-binary-encoding-test (make-instance 'mysql-date-time) #(#x00) #(#.+mysql-type-datetime+ #x00))) (define-test binary-encoding-datetime-2 () (generate-binary-encoding-test (make-instance 'mysql-date-time :year 1900 :month 1 :day 2) #(#x04 #x6c #x07 #x01 #x02) #(#.+mysql-type-datetime+ #x00))) (define-test binary-encoding-datetime-3 () (generate-binary-encoding-test (make-instance 'mysql-date-time :year 1900 :month 1 :day 2 :hour 3 :minute 4 :second 5 ) #(#x07 #x6c #x07 #x01 #x02 #x03 #x04 #x05) #(#.+mysql-type-datetime+ #x00))) (define-test binary-encoding-datetime-4 () (generate-binary-encoding-test (make-instance 'mysql-date-time :year 1900 :month 01 :day 01 :hour 12 :microsecond 1) #(#x0b #x6c #x07 #x01 #x01 #x0c #x00 #x00 #x01 #x00 #x00 #x00) #(#.+mysql-type-datetime+ #x00))) ;; Time Intervals, at lengths 0, 8, and 12 (define-test binary-encoding-time-1 () (generate-binary-encoding-test (make-instance 'mysql-time-interval) #(#x00) #(#.+mysql-type-time+ #x00))) (define-test binary-encoding-time-2 () (generate-binary-encoding-test (make-instance 'mysql-time-interval :days 1 :hours 2 :minutes 3 :seconds 4) #(#x08 #x00 #x01 #x00 #x00 #x00 #x02 #x03 #x04) #(#.+mysql-type-time+ #x00))) (define-test binary-encoding-time-3 () (generate-binary-encoding-test (make-instance 'mysql-time-interval :microseconds 1) #(#x0c #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x00) #(#.+mysql-type-time+ #x00))) (define-test binary-encoding-time-4 () (generate-binary-encoding-test (make-instance 'mysql-time-interval :microseconds 1 :negativep t) #(#x0c #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x00) #(#.+mysql-type-time+ #x00))) (define-test binary-encoding-time-5 () (generate-binary-encoding-test (make-instance 'mysql-time-interval :negativep t :days 1 :hours 2 :minutes 3 :seconds 4) #(#x08 #x01 #x01 #x00 #x00 #x00 #x02 #x03 #x04) #(#.+mysql-type-time+ #x00))) ;; Years, which travel like shorts (define-test binary-encoding-year-1 () (generate-binary-encoding-test (make-instance 'mysql-year) #(#x00 #x00) #(#.+mysql-type-year+ #x00))) (define-test binary-encoding-year-2 () (generate-binary-encoding-test (make-instance 'mysql-year :year 1900) #(#x6c #x07) #(#.+mysql-type-year+ #x00))) (define-test-suite binary-encoding-date-time-suite () (binary-encoding-datetime-1 binary-encoding-datetime-2 binary-encoding-datetime-3 binary-encoding-datetime-4 binary-encoding-time-1 binary-encoding-time-2 binary-encoding-time-3 binary-encoding-time-4 binary-encoding-time-5 binary-encoding-year-1 binary-encoding-year-2)) (define-test-suite mysql-binary-encoding-suite () (binary-encoding-octets-suite binary-encoding-string-suite binary-encoding-integer-suite binary-encoding-ratio-suite binary-encoding-float-suite binary-encoding-date-time-suite)) (register-test 'mysql-binary-encoding-suite) qmynd-20170630-git/tests/parsing.lisp000066400000000000000000000076701312441320500173720ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-test) #| Dependencies to add: • flexi-streams ✓ • babel ✓ Tests to write • Parsing • Integers • Decoding fixed-length integers ✓ • Decoding length-encoded integers ✓ • Negative tests for decoding • #xfb as NULL • #xfe as EOF packet • #xff as Error packet • Strings • Decoding fixed-length strings ✓ • Decoding null-terminated strings ✓ • Decoding variable-length strings ✗ • Decoding length-encoded strings ✓ • Decoding rest-of-packet strings ✗ • Packets • Single packets • Multiple packets • Multi-packet single payload • Sequence IDs • Response Packets • OK_Packet [00] • With CLIENT_PROTOCOL_41 (includes warning count) • Without CLIENT_PROTOCOL_41 (no warning count) • ERR_Packet [ff] • With CLIENT_PROTOCOL_41 (includes #sql-state) • Without CLIENT_PROTOCOL_41 (no #sql-state) • EOF_Packet [fe] • With CLIENT_PROTOCOL_41 (includes warning count and status flags) • Without CLIENT_PROTOCOL_41 (no warning count and status flags) • Status flags? • Character Sets • ASCII • UTF-8 • Others? (Depend on Babel) • Generating • Integers • Encoding fixed-length integers ✓ • Encoding length-encoded integers ✓ • Strings • Encoding fixed-length strings • Encoding null-terminated strings • Encoding variable-length strings • Encoding length-encoded strings • Encoding rest-of-packet strings • Connecting • Initial Packet / Capability Negotiation • Protocol::HandshakeV10 (valid since MySQL 3.21.0) • Be ready to support newer handshakes. • Error out on older Handshakes and servers that don't support CLIENT_PROTOCOL_41 • SSL Negotiation (?) • Protocol::SSLRequest • Client Response • Protocol::HandshakeResponse41 • Authentication • Success • Failure • Switch Method (MySQL 5.5.7+) • Protocol::AuthSwitchRequest • Protocol::OldAuthSwitchRequest (?) • Protocol::AuthSwitchResponse • Protocol::AuthMoreData … • Methods • Old Password Authentication (Insecure — Force fail by default.) • Secure Password Authentication • Sending Commands • Text Protocol • [00] Sleep • [01] Quit • [02] Initialize Database • [03] Query • [04] Field List • [05] Create Database • [06] Drop Database • [07] Refresh • [08] Shutdown • [09] Statistics • [0a] Process Information • [0b] Connect • [0c] Process Kill • [0d] Debug • [0e] Ping • [0f] Time • [10] Delayed Insert • [11] Change User • [1d] Daemon • Prepared Statements • [16] Statement Prepare • [17] Statement Execute • [18] Statement Send Long Data • [19] Statement Close • [1a] Statement Reset • Replication Protocol (server-to-server master/slave commands; no initial support here) • [12] Binary Log Dump • [13] Table Dump • [14] Connect Out • [15] Register Slave • [1e] Binary Log Dump GTID • Stored Procedures • [1b] Set Option • [1c] Statement Fetch |# qmynd-20170630-git/tests/pkgdcl.lisp000066400000000000000000000042551312441320500171670ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :cl-user) ;;; Package declaration for MySQL Native Driver tests (defpackage :qmynd-test (:use :common-lisp :qmynd-impl) #+test-tools (:import-from :qtest #:define-test #:define-test-suite #:register-test #:run-test #:assert-equal #:assert-equal-helper #:assert-true #:assert-false) (:import-from :qmynd-impl ;; utilities #:single-float-bits #:double-float-bits #:make-single-float #:make-double-float #:encode-binary-parameter #:read-wire-packet ;; MySQL Basic Type I/O #:read-fixed-length-integer #:read-length-encoded-integer #:read-fixed-length-octets #:read-null-terminated-octets #:read-length-encoded-octets #:write-fixed-length-integer #:write-length-encoded-integer ;; MySQL Date/Time classes #:mysql-date-time #:mysql-time-interval #:mysql-year ;; MySQL Constants #:+mysql-type-decimal+ #:+mysql-type-tiny+ #:+mysql-type-short+ #:+mysql-type-long+ #:+mysql-type-float+ #:+mysql-type-double+ #:+mysql-type-null+ #:+mysql-type-timestamp+ #:+mysql-type-longlong+ #:+mysql-type-int24+ #:+mysql-type-date+ #:+mysql-type-time+ #:+mysql-type-datetime+ #:+mysql-type-year+ #:+mysql-type-newdate+ #:+mysql-type-varchar+ #:+mysql-type-bit+ #:+mysql-type-newdecimal+ #:+mysql-type-enum+ #:+mysql-type-set+ #:+mysql-type-tiny-blob+ #:+mysql-type-medium-blob+ #:+mysql-type-long-blob+ #:+mysql-type-blob+ #:+mysql-type-var-string+ #:+mysql-type-string+ #:+mysql-type-geometry+)) qmynd-20170630-git/tests/qmynd-test.asd000066400000000000000000000032751312441320500176310ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Alejandro Sedeño ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (asdf:defsystem :qmynd-test :name "MySQL Native Driver - Test Suite" :author "Alejandro Sedeño" :version "1.0" :licence "MIT-style" :maintainer '("Alejandro Sedeño") :description "Test code for MySQL Native Driver" :long-description "Test code for MySQL Native Driver for Common Lisp" :depends-on (:babel :flexi-streams :qmynd) :serial nil :components ((:module "packages" :serial nil :pathname #p"" :components ((:file "pkgdcl"))) (:module "common" :serial nil :pathname #p"" :depends-on ("packages") :components (#-test-tools (:file "qtest"))) (:module "parsing" :serial nil :pathname #p"" :depends-on ("common") :components ((:file "parsing") (:file "basic-types"))) (:module "encoding" :serial nil :pathname #p"" :depends-on ("common") :components ((:file "binary-encoding"))))) qmynd-20170630-git/tests/qtest.lisp000066400000000000000000000043631312441320500170630ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Scott McKay ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :qmynd-test) ;;; Ultra light-weight test framework (defmacro define-test (test-name () &body body) `(defun ,test-name () (handler-case (progn ,@body) (error (e) (warn "An error was signalled executing ~S:~% ~A" ',test-name e))))) (defmacro define-test-suite (suite-name () &body body) (if (listp (car body)) ;; QRes-style body `(defun ,suite-name () ,@(loop for test in (car body) collect (list test))) ;; The more sensible style `(defun ,suite-name () ,@(loop for test in body collect (list test))))) (defvar *all-registered-tests* ()) (defmacro register-test (test-name) `(pushnew ,test-name *all-registered-tests*)) (defmacro run-test (test-name) `(progn (format t "~&Running test ~A" ',test-name) (funcall ',test-name))) (defun run-all-tests () (dolist (test *all-registered-tests*) (format t "~&Running test ~A" test) (funcall test))) (defmacro assert-equal (actual expected &key (test ''equal)) `(assert-equal-helper ',actual ,actual ',expected ,expected ,test)) (defun assert-equal-helper (actual-form actual expected-form expected test) (unless (funcall test actual expected) (warn "These two expressions yield values that are not ~S:~% ~S => ~S~%~S => ~S" test actual-form actual expected-form expected))) (defmacro assert-true (form) `(unless ,form (warn "The value ~S does not evaluate to 'true'" ',form))) (defmacro assert-false (form) `(when ,form (warn "The value ~S does not evaluate to 'false'" ',form)))