diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,23 @@ -# Revision history for mysql-pure +# Revision history for mysql-haskell -## 1.1.1 -- TBD +## 1.1.2 -- 2023.08.14 ++ Fix package name of changelog ++ Drop support for RC4 chipher which is depracated ++ drop dependency on binary-ieee754, which was unused. ++ Fix text 2 support, thanks @RikvanToor + +## 1.1.1 -- 2023.08.14 + + cleaned up some warnings ++ Merge back into mysql-haskell after gaining hackage access. ++ Deprecate mysql-pure in favor of old hackage + since it's only been out for a day this sort off + stream lines upgrading for most applications. + Cabal will just figure it out, rather then + users having to "find" mysql-pure. + I'll just make a bonus announcement to + let people not depend on mysql-pure. ## 1.1.0 -- 2023.08.12 There was a bunch of stuff unrelated to mysql diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: mysql-haskell -version: 1.1.0 +version: 1.1.2 synopsis: pure haskell MySQL driver description: pure haskell MySQL driver. license: BSD-3-Clause @@ -74,7 +74,6 @@ build-depends: base >=4.7 && <4.19.0, binary >=0.8.3 && <0.9, - binary-ieee754 >=0.1.0 && <0.2, blaze-textual >=0.2 && <0.3, bytestring >=0.10.2.0 && <0.12 || ^>=0.12.0, bytestring-lexing >=0.5 && <0.6, diff --git a/src/Data/TLSSetting.hs b/src/Data/TLSSetting.hs --- a/src/Data/TLSSetting.hs +++ b/src/Data/TLSSetting.hs @@ -45,7 +45,9 @@ makeCAStore MozillaCAStore = makeCAStore . CustomCAStore =<< mozillaCAStorePath makeCAStore (CustomCAStore fp) = do bs <- B.readFile fp - let Right pems = X509.pemParseBS bs + let pems = case X509.pemParseBS bs of + Right pms -> pms + Left err -> error err case mapM (X509.decodeSignedCertificate . X509.pemContent) pems of Right cas -> return (X509.makeCertificateStore cas) Left err -> error err @@ -65,7 +67,7 @@ makeClientParams tca = do caStore <- makeCAStore tca return (TLS.defaultParamsClient "" B.empty) - { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_all } + { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default } , TLS.clientShared = def { TLS.sharedCAStore = caStore , TLS.sharedValidationCache = def diff --git a/src/Database/MySQL/Base.hs b/src/Database/MySQL/Base.hs --- a/src/Database/MySQL/Base.hs +++ b/src/Database/MySQL/Base.hs @@ -74,7 +74,6 @@ , module Database.MySQL.Protocol.MySQLValue ) where -import Control.Applicative import Control.Exception (mask, onException, throwIO) import Control.Monad import qualified Data.ByteString.Lazy as L diff --git a/src/Database/MySQL/BinLogProtocol/BinLogEvent.hs b/src/Database/MySQL/BinLogProtocol/BinLogEvent.hs --- a/src/Database/MySQL/BinLogProtocol/BinLogEvent.hs +++ b/src/Database/MySQL/BinLogProtocol/BinLogEvent.hs @@ -14,7 +14,6 @@ module Database.MySQL.BinLogProtocol.BinLogEvent where -import Control.Applicative import Control.Monad import Control.Monad.Loops (untilM) import Data.Binary @@ -230,7 +229,7 @@ extraLen <- getWord16le void $ getByteString (fromIntegral extraLen - 2) colCnt <- getLenEncInt - let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8 + let (plen, poffset) = (colCnt + 7) `quotRem` 8 pmap <- getPresentMap plen poffset DeleteRowsEvent tid flgs colCnt pmap <$> untilM (getBinLogRow (tmColumnMeta tme) pmap) isEmpty @@ -252,7 +251,7 @@ extraLen <- getWord16le void $ getByteString (fromIntegral extraLen - 2) colCnt <- getLenEncInt - let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8 + let (plen, poffset) = (colCnt + 7) `quotRem` 8 pmap <- getPresentMap plen poffset WriteRowsEvent tid flgs colCnt pmap <$> untilM (getBinLogRow (tmColumnMeta tme) pmap) isEmpty @@ -274,7 +273,7 @@ extraLen <- getWord16le void $ getByteString (fromIntegral extraLen - 2) colCnt <- getLenEncInt - let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8 + let (plen, poffset) = (colCnt + 7) `quotRem` 8 pmap <- getPresentMap plen poffset pmap' <- getPresentMap plen poffset UpdateRowsEvent tid flgs colCnt (pmap, pmap') <$> diff --git a/src/Database/MySQL/BinLogProtocol/BinLogMeta.hs b/src/Database/MySQL/BinLogProtocol/BinLogMeta.hs --- a/src/Database/MySQL/BinLogProtocol/BinLogMeta.hs +++ b/src/Database/MySQL/BinLogProtocol/BinLogMeta.hs @@ -28,7 +28,6 @@ module Database.MySQL.BinLogProtocol.BinLogMeta where -import Control.Applicative import Data.Binary.Get import Data.Bits import Data.Word diff --git a/src/Database/MySQL/BinLogProtocol/BinLogValue.hs b/src/Database/MySQL/BinLogProtocol/BinLogValue.hs --- a/src/Database/MySQL/BinLogProtocol/BinLogValue.hs +++ b/src/Database/MySQL/BinLogProtocol/BinLogValue.hs @@ -13,9 +13,7 @@ module Database.MySQL.BinLogProtocol.BinLogValue where -import Control.Applicative import Data.Binary.Get -import Data.Binary.IEEE754 import Data.Binary.Put () import Data.Bits import Data.ByteString (ByteString) @@ -206,7 +204,7 @@ -- following a simple lookup table. -- getBinLogField (BINLOG_TYPE_NEWDECIMAL precision scale) = do - let i = fromIntegral (precision - scale) + let i = (precision - scale) (ucI, cI) = i `quotRem` digitsPerInteger (ucF, cF) = scale `quotRem` digitsPerInteger ucISize = fromIntegral (ucI `shiftL` 2) @@ -215,7 +213,7 @@ cFSize = fromIntegral (sizeTable `B.unsafeIndex` fromIntegral cF) len = ucISize + cISize + ucFSize + cFSize - buf <- getByteString (fromIntegral len) + buf <- getByteString len let fb = buf `B.unsafeIndex` 0 sign = if fb .&. 0x80 == 0x80 then 1 else 0 :: Word8 @@ -254,7 +252,7 @@ getBinLogField (BINLOG_TYPE_ENUM size) = if | size == 1 -> BinLogEnum . fromIntegral <$> getWord8 - | size == 2 -> BinLogEnum . fromIntegral <$> getWord16be + | size == 2 -> BinLogEnum <$> getWord16be | otherwise -> fail $ "Database.MySQL.BinLogProtocol.BinLogValue: wrong \ \BINLOG_TYPE_ENUM size: " ++ show size 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 @@ -13,7 +13,6 @@ module Database.MySQL.Connection where -import Control.Applicative import Control.Exception (Exception, bracketOnError, throwIO, catch, SomeException) import Control.Monad @@ -234,7 +233,7 @@ writeCommand :: Command -> (Packet -> IO ()) -> IO () writeCommand a writePacket = let bs = Binary.runPut (putCommand a) in - go (fromIntegral (L.length bs)) 0 bs writePacket + go (L.length bs) 0 bs writePacket where go len seqN bs writePacket' = do if len < 16777215 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 @@ -16,7 +16,6 @@ module Database.MySQL.Protocol.Auth where -import Control.Applicative import Control.Monad import Data.Binary import Data.Binary.Get @@ -97,7 +96,7 @@ status <- getWord16le capH <- getWord16le let cap = fromIntegral capH `shiftL` 16 .|. fromIntegral capL - authPluginLen <- getWord8 -- this will issue an unused warning, see the notes below + _authPluginLen <- getWord8 -- this will issue an unused warning, see the notes below skipN 10 -- 10 * 0x00 salt2 <- if (cap .&. CLIENT_SECURE_CONNECTION) == 0 then pure B.empty diff --git a/src/Database/MySQL/Protocol/ColumnDef.hs b/src/Database/MySQL/Protocol/ColumnDef.hs --- a/src/Database/MySQL/Protocol/ColumnDef.hs +++ b/src/Database/MySQL/Protocol/ColumnDef.hs @@ -16,7 +16,6 @@ module Database.MySQL.Protocol.ColumnDef where -import Control.Applicative import Data.Binary import Data.Binary.Get import Data.Binary.Parser diff --git a/src/Database/MySQL/Protocol/Command.hs b/src/Database/MySQL/Protocol/Command.hs --- a/src/Database/MySQL/Protocol/Command.hs +++ b/src/Database/MySQL/Protocol/Command.hs @@ -15,7 +15,6 @@ module Database.MySQL.Protocol.Command where -import Control.Applicative import Control.Monad import Data.Binary import Data.Binary.Get diff --git a/src/Database/MySQL/Protocol/Escape.hs b/src/Database/MySQL/Protocol/Escape.hs --- a/src/Database/MySQL/Protocol/Escape.hs +++ b/src/Database/MySQL/Protocol/Escape.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-| Module : Database.MySQL.Protocol.Escape @@ -32,6 +33,7 @@ module Database.MySQL.Protocol.Escape where +import Control.Monad (forM_) import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as B import Data.Text (Text) @@ -44,6 +46,7 @@ import GHC.IO (unsafeDupablePerformIO) escapeText :: Text -> Text +#if MIN_VERSION_text(2,0,0) escapeText (T.Text arr off len) | len <= 0 = T.empty | otherwise = @@ -60,6 +63,41 @@ | ix == oend = return (marr, ix') | otherwise = do let c = TA.unsafeIndex oarr ix + cs = c : [ TA.unsafeIndex oarr (ix+1) | c >= 0xC0 ] + ++ [ TA.unsafeIndex oarr (ix+2) | c >= 0xE0 ] + ++ [ TA.unsafeIndex oarr (ix+3) | c >= 0xF0 ] + go2 = loop oarr oend marr (ix+1) (ix'+2) + goN = do + forM_ (zip [0..4] cs) $ \(di,c') -> TA.unsafeWrite marr (ix' + di) c' + loop oarr oend marr (ix + length cs) (ix' + length cs) + if | c == 0 + || c == 39 + || c == 34 -> escape c marr ix' >> go2 -- \0 \' \" + | c == 8 -> escape 98 marr ix' >> go2 -- \b + | c == 10 -> escape 110 marr ix' >> go2 -- \n + | c == 13 -> escape 114 marr ix' >> go2 -- \r + | c == 9 -> escape 116 marr ix' >> go2 -- \t + | c == 26 -> escape 90 marr ix' >> go2 -- \Z + | c == 92 -> escape 92 marr ix' >> go2 -- \\ + + | otherwise -> goN +#else +escapeText (T.Text arr off len) + | len <= 0 = T.empty + | otherwise = + let (arr', len') = TA.run2 $ do + marr <- TA.new (len * 2) + loop arr (off + len) marr off 0 + in T.Text arr' 0 len' + where + escape c marr ix = do + TA.unsafeWrite marr ix 92 + TA.unsafeWrite marr (ix+1) c + + loop oarr oend marr !ix !ix' + | ix == oend = return (marr, ix') + | otherwise = do + let c = TA.unsafeIndex oarr ix go1 = loop oarr oend marr (ix+1) (ix'+1) go2 = loop oarr oend marr (ix+1) (ix'+2) if | c >= 0xD800 && c <= 0xDBFF -> do let c2 = TA.unsafeIndex oarr (ix+1) @@ -77,6 +115,7 @@ | c == 92 -> escape 92 marr ix' >> go2 -- \\ | otherwise -> TA.unsafeWrite marr ix' c >> go1 +#endif escapeBytes :: ByteString -> ByteString escapeBytes (B.PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \ a -> 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 @@ -34,11 +34,9 @@ ) where import qualified Blaze.Text as Textual -import Control.Applicative import Control.Monad import Data.Binary.Put import Data.Binary.Parser -import Data.Binary.IEEE754 import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -294,7 +292,7 @@ | t == mySQLTypeLong || t == mySQLTypeInt24 = if isUnsigned then MySQLInt32U <$> getWord32le else MySQLInt32 <$> getInt32le - | t == mySQLTypeYear = MySQLYear . fromIntegral <$> getWord16le + | t == mySQLTypeYear = MySQLYear <$> getWord16le | t == mySQLTypeLongLong = if isUnsigned then MySQLInt64U <$> getWord64le else MySQLInt64 <$> getInt64le | t == mySQLTypeFloat = MySQLFloat <$> getFloatle @@ -386,7 +384,7 @@ getSecond4 :: Get Pico getSecond4 = realToFrac <$> getWord8 getSecond8 :: Get Pico - getSecond8 = realToFrac <$> do + getSecond8 = do s <- getInt8' ms <- fromIntegral <$> getWord32le :: Get Int pure $! (realToFrac s + realToFrac ms / 1000000 :: Pico) @@ -402,10 +400,10 @@ | bytes == 2 -> fromIntegral <$> getWord16be | bytes == 3 -> fromIntegral <$> getWord24be | bytes == 4 -> fromIntegral <$> getWord32be - | bytes == 5 -> fromIntegral <$> getWord40be - | bytes == 6 -> fromIntegral <$> getWord48be - | bytes == 7 -> fromIntegral <$> getWord56be - | bytes == 8 -> fromIntegral <$> getWord64be + | bytes == 5 -> getWord40be + | bytes == 6 -> getWord48be + | bytes == 7 -> getWord56be + | bytes == 8 -> getWord64be | otherwise -> fail $ "Database.MySQL.Protocol.MySQLValue: \ \wrong bit length size: " ++ show bytes {-# INLINE getBits #-} 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 @@ -15,7 +15,6 @@ module Database.MySQL.Protocol.Packet where -import Control.Applicative import Control.Exception (Exception (..), throwIO) import Data.Binary.Parser import Data.Binary.Put @@ -50,7 +49,7 @@ getPacket = do len <- fromIntegral <$> getWord24le seqN <- getWord8 - body <- getLazyByteString (fromIntegral len) + body <- getLazyByteString len return (Packet len seqN body) {-# INLINE getPacket #-} @@ -101,14 +100,14 @@ encodeToPacket seqN payload = let s = encode payload l = L.length s - in Packet (fromIntegral l) seqN s + in Packet l seqN s {-# INLINE encodeToPacket #-} putToPacket :: Word8 -> Put -> Packet putToPacket seqN payload = let s = runPut payload l = L.length s - in Packet (fromIntegral l) seqN s + in Packet l seqN s {-# INLINE putToPacket #-} -------------------------------------------------------------------------------- diff --git a/src/System/IO/Streams/TCP.hs b/src/System/IO/Streams/TCP.hs --- a/src/System/IO/Streams/TCP.hs +++ b/src/System/IO/Streams/TCP.hs @@ -81,10 +81,10 @@ return (sock, addr) ) where - resolveAddrInfo host port = do + resolveAddrInfo host' port' = do -- Partial function here OK, network will throw an exception rather than -- return the empty list here. - (addrInfo:_) <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) + (addrInfo:_) <- N.getAddrInfo (Just hints) (Just host') (Just $ show port') let family = N.addrFamily addrInfo let socketType = N.addrSocketType addrInfo let protocol = N.addrProtocol addrInfo @@ -107,11 +107,11 @@ is <- S.makeInputStream $ do s <- NB.recv sock bufsiz return $! if B.null s then Nothing else Just s - return (Connection is (send sock) (N.close sock) (sock, addr)) + return (Connection is (send' sock) (N.close sock) (sock, addr)) where - send _ (L.Empty) = return () - send sock (L.Chunk bs L.Empty) = unless (B.null bs) (NB.sendAll sock bs) - send sock lbs = NL.sendAll sock lbs + send' _ (L.Empty) = return () + send' sock' (L.Chunk bs L.Empty) = unless (B.null bs) (NB.sendAll sock' bs) + send' sock' lbs = NL.sendAll sock' lbs -- | Connect to server using 'defaultChunkSize'. --