Add caching_sha2_password authentication support

mysql-haskell.cabal

@@ -128,6 +128,7 @@ test-suite test
     QC.Combinator
     QC.Common
     Orphans
+    Sha256Scramble
     TCPStreams
     Word24
 
@@ -168,6 +169,7 @@ test-suite integration
     BinaryRowNew
     BinLog
     BinLogNew
+    CachingSha2
     ExecuteMany
     MysqlTests
     RoundtripBit

nix/ci.nix

@@ -16,7 +16,7 @@ in
       server.succeed("mysql -u root -e \"CREATE USER 'testMySQLHaskell'@'localhost';\"")
       server.succeed("mysql -u root -e \"CREATE DATABASE testMySQLHaskell;\"")
       server.succeed("mysql -u root -e \"GRANT ALL ON testMySQLHaskell.* TO 'testMySQLHaskell'@'localhost';\"")
-      server.succeed("mysql -u root -e \"GRANT BINLOG MONITOR, REPLICATION SLAVE ON *.* TO 'testMySQLHaskell'@'localhost';\"")
+      server.succeed("mysql -u root -e \"GRANT BINLOG MONITOR, REPLICATION SLAVE, CREATE USER ON *.* TO 'testMySQLHaskell'@'localhost';\"")
       print(server.succeed("${package}/bin/integration/integration"))
     '';
     nodes.server = {
@@ -34,4 +34,48 @@ in
       };
     };
   };
+  integrated-checks-mysql80 = pkgs.testers.nixosTest {
+    name = "mysql-haskell-mysql80-test";
+    testScript = ''
+      server.start()
+      server.wait_for_unit("mysql.service")
+      server.wait_until_succeeds("mysql -u root -e 'SELECT 1'")
+
+      server.succeed("mysql -u root -e \"CREATE DATABASE testMySQLHaskell;\"")
+
+      # Main test user (mysql_native_password so existing tests including password change work over plain TCP)
+      server.succeed("mysql -u root -e \"CREATE USER 'testMySQLHaskell'@'localhost' IDENTIFIED WITH mysql_native_password;\"")
+      server.succeed("mysql -u root -e \"GRANT ALL ON testMySQLHaskell.* TO 'testMySQLHaskell'@'localhost';\"")
+      server.succeed("mysql -u root -e \"GRANT REPLICATION SLAVE, REPLICATION CLIENT, CREATE USER ON *.* TO 'testMySQLHaskell'@'localhost';\"")
+
+      # User with caching_sha2_password (MySQL 8.0 default) for SHA256 fast auth test
+      server.succeed("mysql -u root -e \"CREATE USER 'testMySQLHaskellSha2'@'localhost' IDENTIFIED BY 'testPassword123';\"")
+      server.succeed("mysql -u root -e \"GRANT ALL ON testMySQLHaskell.* TO 'testMySQLHaskellSha2'@'localhost';\"")
+
+      # User with mysql_native_password for AuthSwitchRequest test
+      server.succeed("mysql -u root -e \"CREATE USER 'testMySQLHaskellNative'@'localhost' IDENTIFIED WITH mysql_native_password BY 'nativePass123';\"")
+      server.succeed("mysql -u root -e \"GRANT ALL ON testMySQLHaskell.* TO 'testMySQLHaskellNative'@'localhost';\"")
+
+      # Pre-cache the caching_sha2_password verifier by logging in via unix socket
+      server.succeed("mysql -u testMySQLHaskellSha2 -ptestPassword123 -e 'SELECT 1'")
+
+      # Run the full integration test suite (sha2 tests are conditionally included for MySQL 8.0+)
+      print(server.succeed("${package}/bin/integration/integration"))
+    '';
+    nodes.server = {
+      virtualisation.memorySize = 2048;
+      virtualisation.diskSize = 1024;
+      services.mysql = {
+        enable = true;
+        package = pkgs.mysql80;
+        settings.mysqld = {
+          max_allowed_packet = "256M";
+          log_bin = "mysql-bin";
+          server_id = 1;
+          binlog_format = "ROW";
+          default_authentication_plugin = "caching_sha2_password";
+        };
+      };
+    };
+  };
 }

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,37 +126,107 @@
         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
 
 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)
-
-    sha1 :: ByteString -> ByteString
-    sha1 = BA.convert . (Crypto.hash :: ByteString -> Crypto.Digest Crypto.SHA1)
+        plugin = greetingAuthPlugin greet
+        scambleBuf = scrambleForPlugin plugin salt pass
+    in Auth clientCap clientMaxPacketSize charset user scambleBuf db plugin
+
+-- | 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)
@@ -267,15 +339,15 @@
 --------------------------------------------------------------------------------
 -- Exceptions
 
 data NetworkException = NetworkException deriving (Typeable, Show)
 instance Exception NetworkException
 
 data UnconsumedResultSet = UnconsumedResultSet deriving (Typeable, Show)
 instance Exception UnconsumedResultSet
 
 data ERRException = ERRException ERR deriving (Typeable, Show)
 instance Exception ERRException
 
 data UnexpectedPacket = UnexpectedPacket Packet deriving (Typeable, Show)
 instance Exception UnexpectedPacket
 

src/Database/MySQL/Protocol/Auth.hs

@@ -122,6 +122,7 @@ data Auth = Auth
     , authName      :: !ByteString
     , authPassword  :: !ByteString
     , authSchema    :: !ByteString
+    , authPlugin    :: !ByteString
     } deriving (Show, Eq)
 
 getAuth :: Get Auth
@@ -131,10 +132,10 @@ getAuth = do
     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 @@ putAuth (Auth cap m c n p s) = do
     putByteString p
     putByteString s
     putWord8 0x00
+    putByteString plugin
+    putWord8 0x00
 
 instance Binary Auth where
     get = getAuth
@@ -182,6 +185,7 @@ clientCap =  CLIENT_LONG_PASSWORD
                 .|. CLIENT_MULTI_STATEMENTS
                 .|. CLIENT_MULTI_RESULTS
                 .|. CLIENT_SECURE_CONNECTION
+                .|. CLIENT_PLUGIN_AUTH
 
 clientMaxPacketSize :: Word32
 clientMaxPacketSize = 0x00ffffff :: Word32

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
@@ -93,7 +105,7 @@
 {-# INLINE getFromPacket #-}
 
 data DecodePacketException = DecodePacketFailed ByteString ByteOffset String
   deriving (Typeable, Show)
 instance Exception DecodePacketException
 
 encodeToPacket :: Binary a => Word8 -> a -> Packet

src/Database/MySQL/TLS.hs

@@ -17,15 +17,22 @@ module Database.MySQL.TLS (
     , 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 @@ connectDetail (ConnectInfo host port db user pass charset) (cparams, subName) =
                     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

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
+    ]