diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,22 @@ # Revision history for mysql-haskell -## 1.1.8 +## 1.2.0 -- 2026.03.07 ++ Add support for caching_sha2_password authentiation. + +## 1.1.9 -- 2026.03.07 ++ Fix binary protocol error 1210 on modern MySQL/MariaDB: + `MYSQL_TYPE_BIT` and `MYSQL_TYPE_YEAR` are not valid parameter types + for `COM_STMT_EXECUTE`. Send `MySQLBit` as `MYSQL_TYPE_LONGLONG` + (unsigned, little-endian) and `MySQLYear` as `MYSQL_TYPE_SHORT` + (unsigned, 2-byte integer) instead. ++ Fix `MySQLYear` binary encoding: was sending a length-encoded string + which caused data misalignment for all subsequent parameters. ++ Fix version detection for MariaDB 10+/11+ (fractional seconds support). ++ Fix CI: enable binary logging and grant binlog privileges for + integration tests on MariaDB. ++ Add roundtrip integration tests for `MySQLBit` and `MySQLYear`. + +## 1.1.8 + bump constraints ## 1.1.7 -- 2025.08.23 diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: mysql-haskell -version: 1.1.8 +version: 1.2.0 synopsis: pure haskell MySQL driver description: pure haskell MySQL driver. license: BSD-3-Clause @@ -123,20 +123,13 @@ other-modules: Aeson AesonBP - BinaryRow - BinaryRowNew - BinLog - BinLogNew - ExecuteMany JSON - MysqlTests QC.ByteString QC.Combinator QC.Common Orphans + Sha256Scramble TCPStreams - TextRow - TextRowNew Word24 hs-source-dirs: test @@ -154,9 +147,9 @@ quickcheck-instances < 1.0, scientific >=0.3.0, tasty >=0.11 && <2.0, + tasty-expected-failure < 1.0, tasty-hunit < 1.0, tasty-quickcheck >=0.8 && < 1.0, - tasty-expected-failure < 1.0, text, time, unordered-containers < 1.0, @@ -167,6 +160,42 @@ OverloadedStrings ghc-options: -threaded + +test-suite integration + type: exitcode-stdio-1.0 + main-is: Integration.hs + other-modules: + BinaryRow + BinaryRowNew + BinLog + BinLogNew + CachingSha2 + ExecuteMany + MysqlTests + RoundtripBit + RoundtripYear + SelectOne + TextRow + TextRowNew + + hs-source-dirs: test + build-depends: + base, + bytestring >=0.10, + io-streams, + mysql-haskell, + tasty >=0.11 && <2.0, + tasty-hunit < 1.0, + text, + time, + vector + + default-extensions: + MultiWayIf + OverloadedStrings + + ghc-options: -threaded + default-language: Haskell2010 benchmark binary-parsers-bench import: common-options diff --git a/src/Database/MySQL/Connection.hs b/src/Database/MySQL/Connection.hs --- a/src/Database/MySQL/Connection.hs +++ b/src/Database/MySQL/Connection.hs @@ -14,7 +14,9 @@ -} -module Database.MySQL.Connection where +module Database.MySQL.Connection + ( module Database.MySQL.Connection + ) where import Control.Exception (Exception, bracketOnError, throwIO, catch, SomeException) @@ -124,18 +126,16 @@ let auth = mkAuth db user pass charset greet write c $ encodeToPacket 1 auth q <- readPacket is' - if isOK q - then do - consumed <- newIORef True - let waitNotMandatoryOK = catch - (void (waitCommandReply is')) -- server will either reply an OK packet - ((\ _ -> return ()) :: SomeException -> IO ()) -- or directy close the connection - conn = MySQLConn is' - (write c) - (writeCommand COM_QUIT (write c) >> waitNotMandatoryOK >> TCP.close c) - consumed - return (greet, conn) - else TCP.close c >> decodeFromPacket q >>= throwIO . ERRException + completeAuth is' (write c) pass q plainFullAuth + consumed <- newIORef True + let waitNotMandatoryOK = catch + (void (waitCommandReply is')) -- server will either reply an OK packet + ((\ _ -> return ()) :: SomeException -> IO ()) -- or directy close the connection + conn = MySQLConn is' + (write c) + (writeCommand COM_QUIT (write c) >> waitNotMandatoryOK >> TCP.close c) + consumed + return (greet, conn) connectWithBufferSize h p bs = TCP.connectSocket h p >>= TCP.socketToConnection bs write c a = TCP.send c $ Binary.runPut . Binary.put $ a @@ -143,18 +143,90 @@ mkAuth :: ByteString -> ByteString -> ByteString -> Word8 -> Greeting -> Auth mkAuth db user pass charset greet = let salt = greetingSalt1 greet `B.append` greetingSalt2 greet - scambleBuf = scramble salt pass - in Auth clientCap clientMaxPacketSize charset user scambleBuf db - where - scramble :: ByteString -> ByteString -> ByteString - scramble salt pass' - | B.null pass' = B.empty - | otherwise = B.pack (B.zipWith xor sha1pass withSalt) - where sha1pass = sha1 pass' - withSalt = sha1 (salt `B.append` sha1 sha1pass) + plugin = greetingAuthPlugin greet + scambleBuf = scrambleForPlugin plugin salt pass + in Auth clientCap clientMaxPacketSize charset user scambleBuf db plugin - sha1 :: ByteString -> ByteString - sha1 = BA.convert . (Crypto.hash :: ByteString -> Crypto.Digest Crypto.SHA1) +-- | Dispatch scramble based on the authentication plugin name. +scrambleForPlugin :: ByteString -> ByteString -> ByteString -> ByteString +scrambleForPlugin plugin salt pass + | plugin == "caching_sha2_password" = scrambleSHA256 salt pass + | otherwise = scrambleSHA1 salt pass + +-- | SHA1-based scramble for @mysql_native_password@. +scrambleSHA1 :: ByteString -> ByteString -> ByteString +scrambleSHA1 salt pass + | B.null pass = B.empty + | otherwise = B.pack (B.zipWith xor sha1pass withSalt) + where sha1pass = sha1 pass + withSalt = sha1 (salt `B.append` sha1 sha1pass) + sha1 :: ByteString -> ByteString + sha1 = BA.convert . (Crypto.hash :: ByteString -> Crypto.Digest Crypto.SHA1) + +-- | SHA256-based scramble for @caching_sha2_password@. +-- XOR(SHA256(password), SHA256(SHA256(SHA256(password)) + nonce)) +scrambleSHA256 :: ByteString -> ByteString -> ByteString +scrambleSHA256 salt pass + | B.null pass = B.empty + | otherwise = B.pack (B.zipWith xor sha256pass withSalt) + where sha256pass = sha256 pass + withSalt = sha256 (sha256 sha256pass `B.append` salt) + sha256 :: ByteString -> ByteString + sha256 = BA.convert . (Crypto.hash :: ByteString -> Crypto.Digest Crypto.SHA256) + +-- | Handle multi-step authentication after sending the initial auth response. +-- +-- This handles OK, ERR, AuthMoreData (0x01), and AuthSwitchRequest (0xFE). +-- The @fullAuth@ callback is invoked when the server requests full authentication +-- (e.g., cleartext password over TLS). +completeAuth :: InputStream Packet -- ^ packet input stream + -> (Packet -> IO ()) -- ^ packet writer + -> ByteString -- ^ password + -> Packet -- ^ the first response packet from server + -> (Word8 -> ByteString -> (Packet -> IO ()) -> InputStream Packet -> IO ()) + -- ^ full auth callback (seqN, password, writer, input) + -> IO () +completeAuth is writePacket pass p fullAuth + | isOK p = return () + | isERR p = decodeFromPacket p >>= throwIO . ERRException + | isAuthMoreData p = do + let body = L.toStrict (pBody p) + case B.index body 1 of + 0x03 -> do -- fast auth success, read the final OK + ok <- readPacket is + if isOK ok + then return () + else decodeFromPacket ok >>= throwIO . ERRException + 0x04 -> do -- full auth required + fullAuth (pSeqN p + 1) pass writePacket is + _ -> throwIO (UnexpectedPacket p) + | isAuthSwitch p = do + -- Parse AuthSwitchRequest: 0xFE, plugin name (NUL), salt + let body = L.toStrict (pBody p) + rest = B.drop 1 body -- skip 0xFE + (newPlugin, rest') = B.break (== 0) rest + newSalt = B.drop 1 rest' -- skip NUL; trailing NUL may or may not be present + -- Remove trailing NUL from salt if present + newSalt' = if not (B.null newSalt) && B.last newSalt == 0 + then B.init newSalt + else newSalt + scrambled = scrambleForPlugin newPlugin newSalt' pass + seqN = pSeqN p + 1 + responseBody = L.fromStrict scrambled + responsePacket = Packet (fromIntegral (B.length scrambled)) seqN responseBody + writePacket responsePacket + q <- readPacket is + completeAuth is writePacket pass q fullAuth + | otherwise = throwIO (UnexpectedPacket p) + +-- | Full auth handler for plain TCP connections: throws an error because +-- caching_sha2_password full authentication requires a secure connection. +plainFullAuth :: Word8 -> ByteString -> (Packet -> IO ()) -> InputStream Packet -> IO () +plainFullAuth _ _ _ _ = + throwIO $ AuthException "caching_sha2_password full authentication requires a TLS connection. Use Database.MySQL.TLS to connect, or ensure the password verifier is cached (fast auth path)." + +data AuthException = AuthException String deriving (Typeable, Show) +instance Exception AuthException -- | A specialized 'decodeInputStream' here for speed decodeInputStream :: InputStream ByteString -> IO (InputStream Packet) diff --git a/src/Database/MySQL/Protocol/Auth.hs b/src/Database/MySQL/Protocol/Auth.hs --- a/src/Database/MySQL/Protocol/Auth.hs +++ b/src/Database/MySQL/Protocol/Auth.hs @@ -122,6 +122,7 @@ , authName :: !ByteString , authPassword :: !ByteString , authSchema :: !ByteString + , authPlugin :: !ByteString } deriving (Show, Eq) getAuth :: Get Auth @@ -131,10 +132,10 @@ c <- getWord8 skipN 23 n <- getByteStringNul - return $ Auth a m c n B.empty B.empty + return $ Auth a m c n B.empty B.empty B.empty putAuth :: Auth -> Put -putAuth (Auth cap m c n p s) = do +putAuth (Auth cap m c n p s plugin) = do putWord32le cap putWord32le m putWord8 c @@ -144,6 +145,8 @@ putByteString p putByteString s putWord8 0x00 + putByteString plugin + putWord8 0x00 instance Binary Auth where get = getAuth @@ -182,6 +185,7 @@ .|. CLIENT_MULTI_STATEMENTS .|. CLIENT_MULTI_RESULTS .|. CLIENT_SECURE_CONNECTION + .|. CLIENT_PLUGIN_AUTH clientMaxPacketSize :: Word32 clientMaxPacketSize = 0x00ffffff :: Word32 diff --git a/src/Database/MySQL/Protocol/MySQLValue.hs b/src/Database/MySQL/Protocol/MySQLValue.hs --- a/src/Database/MySQL/Protocol/MySQLValue.hs +++ b/src/Database/MySQL/Protocol/MySQLValue.hs @@ -130,14 +130,14 @@ putParamMySQLType (MySQLInt64 _) = putFieldType mySQLTypeLongLong >> putWord8 0x00 putParamMySQLType (MySQLFloat _) = putFieldType mySQLTypeFloat >> putWord8 0x00 putParamMySQLType (MySQLDouble _) = putFieldType mySQLTypeDouble >> putWord8 0x00 -putParamMySQLType (MySQLYear _) = putFieldType mySQLTypeYear >> putWord8 0x80 +putParamMySQLType (MySQLYear _) = putFieldType mySQLTypeShort >> putWord8 0x80 putParamMySQLType (MySQLDateTime _) = putFieldType mySQLTypeDateTime >> putWord8 0x00 putParamMySQLType (MySQLTimeStamp _) = putFieldType mySQLTypeTimestamp>> putWord8 0x00 putParamMySQLType (MySQLDate _) = putFieldType mySQLTypeDate >> putWord8 0x00 putParamMySQLType (MySQLTime _ _) = putFieldType mySQLTypeTime >> putWord8 0x00 putParamMySQLType (MySQLBytes _) = putFieldType mySQLTypeBlob >> putWord8 0x00 putParamMySQLType (MySQLGeometry _) = putFieldType mySQLTypeGeometry >> putWord8 0x00 -putParamMySQLType (MySQLBit _) = putFieldType mySQLTypeBit >> putWord8 0x00 +putParamMySQLType (MySQLBit _) = putFieldType mySQLTypeLongLong >> putWord8 0x80 putParamMySQLType (MySQLText _) = putFieldType mySQLTypeString >> putWord8 0x00 putParamMySQLType MySQLNull = putFieldType mySQLTypeNull >> putWord8 0x00 @@ -424,9 +424,7 @@ putBinaryField (MySQLInt64 n) = putInt64le n putBinaryField (MySQLFloat x) = putFloatle x putBinaryField (MySQLDouble x) = putDoublele x -putBinaryField (MySQLYear n) = putLenEncBytes . L.toStrict . BB.toLazyByteString $ - Textual.integral n -- this's really weird, it's not documented anywhere - -- we must encode year into string in binary mode! +putBinaryField (MySQLYear n) = putWord16le n putBinaryField (MySQLTimeStamp (LocalTime date time)) = do putWord8 11 -- always put full putBinaryDay date putBinaryTime' time @@ -440,8 +438,7 @@ putBinaryTime t putBinaryField (MySQLGeometry bs) = putLenEncBytes bs putBinaryField (MySQLBytes bs) = putLenEncBytes bs -putBinaryField (MySQLBit word) = do putWord8 8 -- always put full - putWord64be word +putBinaryField (MySQLBit word) = putWord64le word putBinaryField (MySQLText t) = putLenEncBytes (T.encodeUtf8 t) putBinaryField MySQLNull = return () diff --git a/src/Database/MySQL/Protocol/Packet.hs b/src/Database/MySQL/Protocol/Packet.hs --- a/src/Database/MySQL/Protocol/Packet.hs +++ b/src/Database/MySQL/Protocol/Packet.hs @@ -71,6 +71,18 @@ isEOF p = L.index (pBody p) 0 == 0xFE {-# INLINE isEOF #-} +-- | Is this an AuthMoreData packet? (first byte 0x01) +-- Used during authentication handshake for caching_sha2_password. +isAuthMoreData :: Packet -> Bool +isAuthMoreData p = L.index (pBody p) 0 == 0x01 +{-# INLINE isAuthMoreData #-} + +-- | Is this an AuthSwitchRequest packet? (first byte 0xFE) +-- Same marker as EOF but used in authentication context. +isAuthSwitch :: Packet -> Bool +isAuthSwitch p = L.index (pBody p) 0 == 0xFE +{-# INLINE isAuthSwitch #-} + -- | Is there more packet to be read? -- -- https://dev.mysql.com/doc/internals/en/status-flags.html diff --git a/src/Database/MySQL/TLS.hs b/src/Database/MySQL/TLS.hs --- a/src/Database/MySQL/TLS.hs +++ b/src/Database/MySQL/TLS.hs @@ -17,15 +17,22 @@ , module Data.TLSSetting ) where -import Control.Exception (bracketOnError, throwIO) +import Control.Exception (bracketOnError, throwIO, catch, SomeException) +import Control.Monad (void) import qualified Data.Binary as Binary import qualified Data.Binary.Put as Binary +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Word (Word8) import qualified Data.Connection as Conn import Data.IORef (newIORef) import Data.TLSSetting import Database.MySQL.Connection hiding (connect, connectDetail) import Database.MySQL.Protocol.Auth +import Database.MySQL.Protocol.Command import Database.MySQL.Protocol.Packet +import System.IO.Streams (InputStream) import qualified Network.TLS as TLS import qualified System.IO.Streams.TCP as TCP import qualified Data.Connection as TCP @@ -63,13 +70,29 @@ let auth = mkAuth db user pass charset greet write tc (encodeToPacket 2 auth) q <- readPacket tlsIs' - if isOK q - then do - consumed <- newIORef True - let conn = MySQLConn tlsIs' (write tc) (TCP.close tc) consumed - return (greet, conn) - else TCP.close c >> decodeFromPacket q >>= throwIO . ERRException + completeAuth tlsIs' (write tc) pass q tlsFullAuth + consumed <- newIORef True + let waitNotMandatoryOK = catch + (void (waitCommandReply tlsIs')) + ((\ _ -> return ()) :: SomeException -> IO ()) + conn = MySQLConn tlsIs' (write tc) + (writeCommand COM_QUIT (write tc) >> waitNotMandatoryOK >> TCP.close tc) + consumed + return (greet, conn) else error "Database.MySQL.TLS: server doesn't support TLS connection" where connectWithBufferSize h p bs = TCP.connectSocket h p >>= TCP.socketToConnection bs write c a = TCP.send c $ Binary.runPut . Binary.put $ a + +-- | Full auth handler for TLS connections: sends the cleartext password +-- as a NUL-terminated packet, which MySQL accepts over encrypted connections. +tlsFullAuth :: Word8 -> ByteString -> (Packet -> IO ()) -> InputStream Packet -> IO () +tlsFullAuth seqN pass writePacket is = do + let payload = pass `B.append` "\0" + body = L.fromStrict payload + pkt = Packet (fromIntegral (B.length payload)) seqN body + writePacket pkt + q <- readPacket is + if isOK q + then return () + else decodeFromPacket q >>= throwIO . ERRException diff --git a/test/CachingSha2.hs b/test/CachingSha2.hs new file mode 100644 --- /dev/null +++ b/test/CachingSha2.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module CachingSha2 (tests) where + +import Database.MySQL.Base +import qualified System.IO.Streams as Stream +import Test.Tasty +import Test.Tasty.HUnit + +-- | These tests exercise two different authentication paths in 'completeAuth'. +-- Both tests connect and run @SELECT 1@, but the server-side auth protocol +-- differs based on which MySQL user is used. The users are created in +-- @nix/ci.nix@ (integrated-checks-mysql80) with different auth plugins: +-- +-- * @testMySQLHaskellSha2@ — created with @caching_sha2_password@ (the MySQL 8.0 +-- default). The client sends a SHA256 scramble, the server responds with +-- AuthMoreData (0x01, byte 2 = 0x03) indicating fast auth success. +-- The CI script pre-caches the verifier via a unix socket login so the +-- fast path is guaranteed. +-- +-- * @testMySQLHaskellNative@ — created with @mysql_native_password@. The server +-- advertises @caching_sha2_password@ in its Greeting, so the client initially +-- sends a SHA256 scramble. The server then responds with AuthSwitchRequest +-- (0xFE) telling the client to re-authenticate using @mysql_native_password@ +-- with a new salt. The client re-scrambles with SHA1 and sends the response. +tests :: TestTree +tests = testGroup "caching_sha2_password" + [ testCaseSteps "SHA256 fast auth" $ \step -> do + step "connecting as testMySQLHaskellSha2 (caching_sha2_password)..." + (_, c) <- connectDetail defaultConnectInfo + { ciUser = "testMySQLHaskellSha2" + , ciPassword = "testPassword123" + , ciDatabase = "testMySQLHaskell" + } + + step "executing SELECT 1..." + (_, is) <- query_ c "SELECT 1" + Just row <- Stream.read is + assertBool "SELECT 1 returns 1" (row == [MySQLInt32 1] || row == [MySQLInt64 1]) + Stream.skipToEof is + + close c + + , testCaseSteps "AuthSwitchRequest handling (mysql_native_password on sha2 server)" $ \step -> do + step "connecting as testMySQLHaskellNative (mysql_native_password)..." + (_, c) <- connectDetail defaultConnectInfo + { ciUser = "testMySQLHaskellNative" + , ciPassword = "nativePass123" + , ciDatabase = "testMySQLHaskell" + } + + step "executing SELECT 1..." + (_, is) <- query_ c "SELECT 1" + Just row <- Stream.read is + assertBool "SELECT 1 returns 1" (row == [MySQLInt32 1] || row == [MySQLInt64 1]) + Stream.skipToEof is + + close c + ] diff --git a/test/Integration.hs b/test/Integration.hs new file mode 100644 --- /dev/null +++ b/test/Integration.hs @@ -0,0 +1,30 @@ +module Main (main) where + +import qualified Data.ByteString as B +import Database.MySQL.Base +import Test.Tasty (defaultMain, testGroup) +import qualified CachingSha2 +import qualified MysqlTests +import qualified RoundtripBit +import qualified RoundtripYear +import qualified SelectOne + +main :: IO () +main = do + -- Connect briefly to detect the server version, so we can conditionally + -- include tests that only apply to certain servers (e.g. caching_sha2 on MySQL 8.0+). + (greet, c) <- connectDetail defaultConnectInfo + {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"} + close c + let ver = greetingVersion greet + isMySql80 = "8." `B.isPrefixOf` ver + || "9." `B.isPrefixOf` ver + defaultMain $ testGroup "mysql-integration" $ + [ SelectOne.tests + , RoundtripBit.tests + , RoundtripYear.tests + , MysqlTests.tests + ] + -- caching_sha2_password is MySQL 8.0+ only (MariaDB does not support it). + -- The sha2 test users are created by the nix CI config for the MySQL 8.0 VM. + ++ [ CachingSha2.tests | isMySql80 ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,7 +4,7 @@ import qualified QC.Combinator as Combinator import Test.Tasty (defaultMain, testGroup) import qualified JSON -import qualified MysqlTests +import qualified Sha256Scramble import qualified Word24 import qualified TCPStreams @@ -17,15 +17,11 @@ , testGroup "combinator" Combinator.tests , testGroup "JSON" jsonTests ], - testGroup "mysql" [ - -- TODO figure out how to run the tests that need a mysql - -- db - -- MysqlTests.tests - ], testGroup "word24" Word24.tests , testGroup "tcp-streams" [ TCPStreams.tests ] + , Sha256Scramble.tests ] diff --git a/test/MysqlTests.hs b/test/MysqlTests.hs --- a/test/MysqlTests.hs +++ b/test/MysqlTests.hs @@ -27,9 +27,11 @@ (greet, c) <- connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"} let ver = greetingVersion greet - isNew = "5.6" `B.isPrefixOf` ver - || "5.7" `B.isPrefixOf` ver -- from MySQL 5.6.4 and up - -- TIME, DATETIME, and TIMESTAMP support fractional seconds + isOld = "5.0" `B.isPrefixOf` ver + || "5.1" `B.isPrefixOf` ver + || "5.5" `B.isPrefixOf` ver + isNew = not isOld -- MySQL 5.6+ and MariaDB 10+ support fractional seconds + -- in TIME, DATETIME, and TIMESTAMP columns execute_ c "DROP TABLE IF EXISTS test" @@ -118,23 +120,24 @@ close c - (greet, c) <- connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"} - execute_ c "SET PASSWORD = PASSWORD('123456abcdefg???')" + step "testing password change" + (_, c) <- connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"} + -- ALTER USER works on both MariaDB and MySQL 8.0 (SET PASSWORD = PASSWORD('...') was removed in MySQL 8.0) + execute_ c "ALTER USER 'testMySQLHaskell'@'localhost' IDENTIFIED BY '123456abcdefg???'" close c - let loginFailMsg = "ERRException (ERR {errCode = 1045, errState = \"28000\", \ - \errMsg = \"Access denied for user 'testMySQLHaskell'@'localhost' (using password: YES)\"})" - - (greet, c) <- connectDetail + (_, c) <- connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell", ciPassword = "123456abcdefg???"} - execute_ c "SET PASSWORD = PASSWORD('')" + execute_ c "ALTER USER 'testMySQLHaskell'@'localhost' IDENTIFIED BY ''" close c catch (void $ connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell", ciPassword = "wrongPassWord"}) - (\ (e :: ERRException) -> assertEqual "wrong password should fail to login" (show e) loginFailMsg) + (\ (e :: ERRException) -> do + let ERRException err = e + assertEqual "wrong password should fail with error 1045" 1045 (errCode err)) where resetTestTable c = do diff --git a/test/RoundtripBit.hs b/test/RoundtripBit.hs new file mode 100644 --- /dev/null +++ b/test/RoundtripBit.hs @@ -0,0 +1,46 @@ +module RoundtripBit (tests) where + +import Database.MySQL.Base +import qualified System.IO.Streams as Stream +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testCaseSteps "roundtrip MySQLBit" $ \step -> do + (_, c) <- connectDetail defaultConnectInfo + { ciUser = "testMySQLHaskell" + , ciDatabase = "testMySQLHaskell" + } + + execute_ c "CREATE TEMPORARY TABLE test_bit (__id INT, __val BIT(16))" + execute_ c "INSERT INTO test_bit VALUES (1, NULL)" + + step "roundtrip MySQLBit via binary protocol" + updStmt <- prepareStmt c "UPDATE test_bit SET __val = ? WHERE __id = 1" + selStmt <- prepareStmt c "SELECT __val FROM test_bit WHERE __id = 1" + + let bitVal = 43744 -- 0b1010101011100000 + executeStmt c updStmt [MySQLBit bitVal] + + (_, is) <- queryStmt c selStmt [] + Just [v] <- Stream.read is + Stream.skipToEof is + assertEqual "MySQLBit roundtrips through BIT(16)" (MySQLBit bitVal) v + + step "roundtrip MySQLBit zero" + executeStmt c updStmt [MySQLBit 0] + + (_, is2) <- queryStmt c selStmt [] + Just [v2] <- Stream.read is2 + Stream.skipToEof is2 + assertEqual "MySQLBit 0 roundtrips" (MySQLBit 0) v2 + + step "roundtrip MySQLBit max for BIT(16)" + executeStmt c updStmt [MySQLBit 65535] + + (_, is3) <- queryStmt c selStmt [] + Just [v3] <- Stream.read is3 + Stream.skipToEof is3 + assertEqual "MySQLBit 65535 roundtrips" (MySQLBit 65535) v3 + + close c diff --git a/test/RoundtripYear.hs b/test/RoundtripYear.hs new file mode 100644 --- /dev/null +++ b/test/RoundtripYear.hs @@ -0,0 +1,53 @@ +module RoundtripYear (tests) where + +import Database.MySQL.Base +import qualified System.IO.Streams as Stream +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testCaseSteps "roundtrip MySQLYear" $ \step -> do + (_, c) <- connectDetail defaultConnectInfo + { ciUser = "testMySQLHaskell" + , ciDatabase = "testMySQLHaskell" + } + + execute_ c "CREATE TEMPORARY TABLE test_year (__id INT, __val YEAR(4))" + execute_ c "INSERT INTO test_year VALUES (1, NULL)" + + step "roundtrip MySQLYear via binary protocol" + updStmt <- prepareStmt c "UPDATE test_year SET __val = ? WHERE __id = 1" + selStmt <- prepareStmt c "SELECT __val FROM test_year WHERE __id = 1" + + executeStmt c updStmt [MySQLYear 1999] + + (_, is) <- queryStmt c selStmt [] + Just [v] <- Stream.read is + Stream.skipToEof is + assertEqual "MySQLYear 1999 roundtrips" (MySQLYear 1999) v + + step "roundtrip MySQLYear min (1901)" + executeStmt c updStmt [MySQLYear 1901] + + (_, is2) <- queryStmt c selStmt [] + Just [v2] <- Stream.read is2 + Stream.skipToEof is2 + assertEqual "MySQLYear 1901 roundtrips" (MySQLYear 1901) v2 + + step "roundtrip MySQLYear max (2155)" + executeStmt c updStmt [MySQLYear 2155] + + (_, is3) <- queryStmt c selStmt [] + Just [v3] <- Stream.read is3 + Stream.skipToEof is3 + assertEqual "MySQLYear 2155 roundtrips" (MySQLYear 2155) v3 + + step "roundtrip MySQLYear zero" + executeStmt c updStmt [MySQLYear 0] + + (_, is4) <- queryStmt c selStmt [] + Just [v4] <- Stream.read is4 + Stream.skipToEof is4 + assertEqual "MySQLYear 0 roundtrips" (MySQLYear 0) v4 + + close c diff --git a/test/SelectOne.hs b/test/SelectOne.hs new file mode 100644 --- /dev/null +++ b/test/SelectOne.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module SelectOne (tests) where + +import Database.MySQL.Base +import qualified System.IO.Streams as Stream +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testCaseSteps "select 1" $ \step -> do + step "connecting..." + (_, c) <- connectDetail defaultConnectInfo + { ciUser = "testMySQLHaskell" + , ciDatabase = "testMySQLHaskell" + } + + step "executing SELECT 1..." + (_, is) <- query_ c "SELECT 1" + Just row <- Stream.read is + -- MySQL 8.0 returns MySQLInt64 for integer literals, older versions return MySQLInt32 + assertBool "SELECT 1 returns 1" (row == [MySQLInt32 1] || row == [MySQLInt64 1]) + Stream.skipToEof is + + close c diff --git a/test/Sha256Scramble.hs b/test/Sha256Scramble.hs new file mode 100644 --- /dev/null +++ b/test/Sha256Scramble.hs @@ -0,0 +1,34 @@ +module Sha256Scramble (tests) where + +import qualified Data.ByteString as B +import Database.MySQL.Connection (scrambleSHA256) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "SHA256 Scramble" + [ testCase "empty password returns empty" $ do + let result = scrambleSHA256 "some_salt" "" + assertEqual "empty password" B.empty result + + , testCase "non-empty password returns 32 bytes" $ do + let result = scrambleSHA256 "12345678901234567890" "password" + assertEqual "scramble length" 32 (B.length result) + + , testCase "different salts produce different scrambles" $ do + let r1 = scrambleSHA256 "salt1_______________" "password" + r2 = scrambleSHA256 "salt2_______________" "password" + assertBool "different salts should produce different results" (r1 /= r2) + + , testCase "different passwords produce different scrambles" $ do + let salt = "12345678901234567890" + r1 = scrambleSHA256 salt "password1" + r2 = scrambleSHA256 salt "password2" + assertBool "different passwords should produce different results" (r1 /= r2) + + , testCase "scramble is deterministic" $ do + let salt = "12345678901234567890" + r1 = scrambleSHA256 salt "testPassword123" + r2 = scrambleSHA256 salt "testPassword123" + assertEqual "same inputs produce same output" r1 r2 + ]