diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,8 @@ # Revision history for mysql-haskell +## 1.2.3 -- 2026.04.12 ++ Support caching_sha2_password full auth via RSA on non-TLS connections#81 thanks @ikaro1192 + ## 1.2.2 -- 2026.03.25 + Widen tls upper bound to allow tls 2.4.x + Fix unsafe ByteString operations (`unsafeDrop`, `unsafeTail`, `unsafeIndex`) 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.2.2 +version: 1.2.3 synopsis: pure haskell MySQL driver description: pure haskell MySQL driver. license: BSD-3-Clause @@ -90,6 +90,8 @@ hs-source-dirs: src other-modules: Database.MySQL.Query build-depends: + asn1-encoding >=0.9 && <0.10, + asn1-types >=0.3 && <0.4, binary >=0.8.3 && <0.9, blaze-textual >=0.2 && <0.3, bytestring >=0.10.2.0 && <0.12 || ^>=0.12.0, @@ -139,6 +141,7 @@ QC.Combinator QC.Common Orphans + Sha1Scramble Sha256Scramble TCPStreams Word24 @@ -146,6 +149,7 @@ hs-source-dirs: test build-depends: attoparsec < 1.0, + base16-bytestring >=1.0 && <2.0, binary >=0.8, bytestring >=0.10, deepseq, @@ -187,6 +191,7 @@ RoundtripYear SelectOne TextRow + TLSConnection TextRowNew UnixSocket 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 @@ -22,6 +22,14 @@ throwIO, catch, SomeException) import Control.Monad import qualified Crypto.Hash as Crypto +import Crypto.Hash.Algorithms (SHA1(..)) +import qualified Crypto.Number.Serialize as Serialize +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.RSA.OAEP as OAEP +import qualified Data.ASN1.BinaryEncoding as ASN1B +import qualified Data.ASN1.BitArray as ASN1BA +import qualified Data.ASN1.Encoding as ASN1E +import qualified Data.ASN1.Types as ASN1 import qualified Data.Binary as Binary import qualified Data.Binary.Put as Binary import Data.Bits @@ -36,6 +44,7 @@ import qualified Data.ByteString.Unsafe as B import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.PEM as PEM import Data.Typeable import Data.Word import Database.MySQL.Protocol.Auth @@ -124,10 +133,11 @@ is' <- decodeInputStream is p <- readPacket is' greet <- decodeFromPacket p - let auth = mkAuth db user pass charset greet + let salt = greetingSalt1 greet `B.append` greetingSalt2 greet + auth = mkAuth db user pass charset greet write c $ encodeToPacket 1 auth q <- readPacket is' - completeAuth is' (write c) pass q plainFullAuth + completeAuth is' (write c) pass q (plainFullAuth salt) consumed <- newIORef True let waitNotMandatoryOK = catch (void (waitCommandReply is')) -- server will either reply an OK packet @@ -165,10 +175,11 @@ is' <- decodeInputStream is p <- readPacket is' greet <- decodeFromPacket p - let auth = mkAuth db user pass charset greet + let salt = greetingSalt1 greet `B.append` greetingSalt2 greet + auth = mkAuth db user pass charset greet write c $ encodeToPacket 1 auth q <- readPacket is' - completeAuth is' (write c) pass q plainFullAuth + completeAuth is' (write c) pass q (plainFullAuth salt) consumed <- newIORef True let waitNotMandatoryOK = catch (void (waitCommandReply is')) -- server will either reply an OK packet @@ -260,11 +271,77 @@ 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)." +-- | Full auth handler for plain TCP connections using RSA encryption. +-- +-- The nonce is captured via partial application at the call site: +-- @completeAuth is writePacket pass q (plainFullAuth salt)@ +plainFullAuth :: ByteString -> Word8 -> ByteString -> (Packet -> IO ()) -> InputStream Packet -> IO () +plainFullAuth nonce seqN pass writePacket is = do + -- Request server's RSA public key + writePacket (putToPacket seqN (Binary.putWord8 0x02)) + keyPkt <- readPacket is + -- Key packet body: 0x01 + let pemKey = L.toStrict (L.drop 1 (pBody keyPkt)) + doRSAAuth writePacket (pSeqN keyPkt + 1) pass nonce pemKey + q <- readPacket is + if isOK q then pure () + else decodeFromPacket q >>= throwIO . ERRException + +-- | Parse a PEM-encoded SubjectPublicKeyInfo RSA public key (PKCS#8 / RFC 5480). +parseRSAPublicKey :: ByteString -> Either String RSA.PublicKey +parseRSAPublicKey pemBytes = + either (Left . show) Right (PEM.pemParseBS pemBytes) + >>= firstPEM + >>= decodeDER + >>= spkiBitString + >>= decodeDER + >>= rsaKey + where + firstPEM [] = Left "empty PEM" + firstPEM (x:_) = Right (PEM.pemContent x) + + decodeDER bs = either (Left . show) Right (ASN1E.decodeASN1' ASN1B.DER bs) + + spkiBitString (ASN1.Start ASN1.Sequence + : ASN1.Start ASN1.Sequence + : ASN1.OID _ + : ASN1.Null + : ASN1.End ASN1.Sequence + : ASN1.BitString bs + : ASN1.End ASN1.Sequence + : []) + = Right (ASN1BA.bitArrayGetData bs) + spkiBitString xs = Left ("unexpected SPKI ASN1: " ++ show xs) + + rsaKey (ASN1.Start ASN1.Sequence + : ASN1.IntVal n + : ASN1.IntVal e + : ASN1.End ASN1.Sequence + : []) + = Right RSA.PublicKey + { RSA.public_size = B.length (Serialize.i2osp n :: ByteString) + , RSA.public_n = n + , RSA.public_e = e + } + rsaKey xs = Left ("unexpected RSA key ASN1: " ++ show xs) + +-- | XOR @(password ++ NUL)@ with a cyclically-extended nonce. +xorPasswordNonce :: ByteString -> ByteString -> ByteString +xorPasswordNonce pass nonce = + let msg = pass `B.snoc` 0x00 + nonceLen = B.length nonce + cycled = B.pack [nonce `B.index` (i `mod` nonceLen) | i <- [0 .. B.length msg - 1]] + in B.pack (B.zipWith xor msg cycled) + +-- | Encrypt password with the server's RSA public key and send it. +doRSAAuth :: (Packet -> IO ()) -> Word8 -> ByteString -> ByteString -> ByteString -> IO () +doRSAAuth writePacket seqN pass nonce pemKey = do + pubKey <- either (\e -> throwIO (userError ("RSA key parse: " ++ e))) pure + (parseRSAPublicKey pemKey) + result <- OAEP.encrypt (OAEP.defaultOAEPParams SHA1) pubKey + (xorPasswordNonce pass nonce) + ct <- either (\e -> throwIO (userError ("RSA encrypt: " ++ show e))) pure result + writePacket (putToPacket seqN (Binary.putByteString ct)) data AuthException = AuthException String deriving (Typeable, Show) instance Exception AuthException diff --git a/test/Integration.hs b/test/Integration.hs --- a/test/Integration.hs +++ b/test/Integration.hs @@ -2,12 +2,14 @@ import qualified Data.ByteString as B import Database.MySQL.Base +import System.Environment (lookupEnv) import Test.Tasty (defaultMain, testGroup) import qualified CachingSha2 import qualified MysqlTests import qualified RoundtripBit import qualified RoundtripYear import qualified SelectOne +import qualified TLSConnection import qualified UnixSocket main :: IO () @@ -22,6 +24,9 @@ -- Probe for a Unix domain socket (MYSQL_UNIX_SOCKET env var, then common paths). mSockPath <- UnixSocket.findSocketPath + -- Probe for TLS CA certificate path (set in NixOS VM tests). + mTlsCaPath <- lookupEnv "MYSQL_TLS_CA_PATH" + defaultMain $ testGroup "mysql-integration" $ [ SelectOne.tests , RoundtripBit.tests @@ -33,3 +38,5 @@ ++ [ CachingSha2.tests | isMySql80 ] -- Unix socket tests are included only when a socket file is found. ++ [ UnixSocket.tests p | Just p <- [mSockPath] ] + -- TLS tests are included only when a CA certificate path is provided. + ++ [ TLSConnection.tests p | Just p <- [mTlsCaPath] ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,7 @@ import qualified QC.Combinator as Combinator import Test.Tasty (defaultMain, testGroup) import qualified JSON +import qualified Sha1Scramble import qualified Sha256Scramble import qualified Word24 import qualified TCPStreams @@ -24,6 +25,7 @@ [ TCPStreams.tests ] + , Sha1Scramble.tests , Sha256Scramble.tests , BoundsCheck.tests ] diff --git a/test/Sha1Scramble.hs b/test/Sha1Scramble.hs new file mode 100644 --- /dev/null +++ b/test/Sha1Scramble.hs @@ -0,0 +1,49 @@ +module Sha1Scramble (tests) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as Base16 +import Data.ByteString.Char8 (pack) +import Database.MySQL.Connection (scrambleSHA1) +import Test.Tasty +import Test.Tasty.HUnit + +hexToBytes :: String -> B.ByteString +hexToBytes = Base16.decodeLenient . pack + +tests :: TestTree +tests = testGroup "SHA1 Scramble" + [ testCase "empty password returns empty" $ do + let result = scrambleSHA1 "some_salt" "" + assertEqual "empty password" B.empty result + + , testCase "non-empty password returns 20 bytes" $ do + let result = scrambleSHA1 "12345678901234567890" "password" + assertEqual "scramble length" 20 (B.length result) + + , testCase "different salts produce different scrambles" $ do + let r1 = scrambleSHA1 "salt1_______________" "password" + r2 = scrambleSHA1 "salt2_______________" "password" + assertBool "different salts should produce different results" (r1 /= r2) + + , testCase "different passwords produce different scrambles" $ do + let salt = "12345678901234567890" + r1 = scrambleSHA1 salt "password1" + r2 = scrambleSHA1 salt "password2" + assertBool "different passwords should produce different results" (r1 /= r2) + + , testCase "scramble is deterministic" $ do + let salt = "12345678901234567890" + r1 = scrambleSHA1 salt "testPassword123" + r2 = scrambleSHA1 salt "testPassword123" + assertEqual "same inputs produce same output" r1 r2 + + , testCase "golden: salt=12345678901234567890 pass=password" $ do + let result = scrambleSHA1 "12345678901234567890" "password" + expected = hexToBytes "1957dce2724282e018f40d905824cb6361f88d41" + assertEqual "golden vector 1" expected result + + , testCase "golden: salt=ABCDEFGHIJKLMNOPQRST pass=secret" $ do + let result = scrambleSHA1 "ABCDEFGHIJKLMNOPQRST" "secret" + expected = hexToBytes "28441590674285e7d03cae7af237504797f70e91" + assertEqual "golden vector 2" expected result + ] diff --git a/test/Sha256Scramble.hs b/test/Sha256Scramble.hs --- a/test/Sha256Scramble.hs +++ b/test/Sha256Scramble.hs @@ -1,10 +1,15 @@ module Sha256Scramble (tests) where import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as Base16 +import Data.ByteString.Char8 (pack) import Database.MySQL.Connection (scrambleSHA256) import Test.Tasty import Test.Tasty.HUnit +hexToBytes :: String -> B.ByteString +hexToBytes = Base16.decodeLenient . pack + tests :: TestTree tests = testGroup "SHA256 Scramble" [ testCase "empty password returns empty" $ do @@ -31,4 +36,14 @@ r1 = scrambleSHA256 salt "testPassword123" r2 = scrambleSHA256 salt "testPassword123" assertEqual "same inputs produce same output" r1 r2 + + , testCase "golden: salt=12345678901234567890 pass=password" $ do + let result = scrambleSHA256 "12345678901234567890" "password" + expected = hexToBytes "718d80fb92b693f7ee1fcad95bfe7a2be1f332ac2c3ec6cdc85893b65b240650" + assertEqual "golden vector 1" expected result + + , testCase "golden: salt=ABCDEFGHIJKLMNOPQRST pass=secret" $ do + let result = scrambleSHA256 "ABCDEFGHIJKLMNOPQRST" "secret" + expected = hexToBytes "d721e183c1f036a196c1389201b8d53f38064a16f1d0923683ab886763152d75" + assertEqual "golden vector 2" expected result ] diff --git a/test/TLSConnection.hs b/test/TLSConnection.hs new file mode 100644 --- /dev/null +++ b/test/TLSConnection.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module TLSConnection (tests) where + +import qualified Data.ByteString as B +import qualified Data.Text as T +import Database.MySQL.Base +import qualified Database.MySQL.TLS as TLS +import Database.MySQL.TLS (makeClientParams, TrustedCAStore(..)) +import qualified System.IO.Streams as Stream +import Test.Tasty +import Test.Tasty.HUnit + +tests :: FilePath -> TestTree +tests caPath = testGroup "tls-connection" + [ testCaseSteps "TLS connectDetail: SELECT 1" $ \step -> do + step "creating TLS client params..." + cparams <- makeClientParams (CustomCAStore caPath) + + step "connecting via TLS..." + (greet, conn) <- TLS.connectDetail + defaultConnectInfo { ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell" } + (cparams, "Winter") + + step "checking greeting version..." + let ver = greetingVersion greet + assertBool "greeting version is not empty" (not $ B.null ver) + + step "executing SELECT 1..." + (_, is) <- query_ conn "SELECT 1" + Just row <- Stream.read is + assertBool "SELECT 1 returns 1" + (row == [MySQLInt32 1] || row == [MySQLInt64 1]) + Stream.skipToEof is + + close conn + + , testCaseSteps "TLS connection: verify encryption active" $ \step -> do + step "creating TLS client params..." + cparams <- makeClientParams (CustomCAStore caPath) + + step "connecting via TLS..." + conn <- TLS.connect + defaultConnectInfo { ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell" } + (cparams, "Winter") + + step "checking SSL cipher..." + (_, is) <- query_ conn "SHOW STATUS LIKE 'Ssl_cipher'" + Just row <- Stream.read is + case row of + [_name, MySQLText cipher] -> + assertBool "SSL cipher is not empty" (not $ T.null cipher) + _ -> assertFailure ("unexpected row shape: " ++ show row) + Stream.skipToEof is + + close conn + + , testCaseSteps "TLS connection: prepared statement roundtrip" $ \step -> do + step "creating TLS client params..." + cparams <- makeClientParams (CustomCAStore caPath) + + step "connecting via TLS..." + conn <- TLS.connect + defaultConnectInfo { ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell" } + (cparams, "Winter") + + step "executing prepared statement..." + stmt <- prepareStmt conn "SELECT ? + 1" + (_, is) <- queryStmt conn stmt [MySQLInt32 41] + Just row <- Stream.read is + assertBool "41 + 1 = 42" + (row == [MySQLInt32 42] || row == [MySQLInt64 42]) + Stream.skipToEof is + + close conn + ]