mysql-haskell 1.2.2 → 1.2.3

raw patch · 8 files changed

+244/−10 lines, 8 filesdep +asn1-encodingdep +asn1-typesdep +base16-bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: asn1-encoding, asn1-types, base16-bytestring

API changes (from Hackage documentation)

Files

• ChangeLog.md +3/−0
• mysql-haskell.cabal +6/−1
• src/Database/MySQL/Connection.hs +86/−9
• test/Integration.hs +7/−0
• test/Main.hs +2/−0
• test/Sha1Scramble.hs +49/−0
• test/Sha256Scramble.hs +15/−0
• test/TLSConnection.hs +76/−0

@@ -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`)

@@ -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 

@@ -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 <PEM bytes>+    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

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

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

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

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

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