From 2786740ee2c3268ef8d6cc27f26ae95565c4708a Mon Sep 17 00:00:00 2001 From: Dong Date: Thu, 13 May 2021 12:26:55 +0800 Subject: [PATCH 1/4] modify packet --- Database/MySQL/Connection.hs | 18 +- Database/MySQL/Protocol/Packet.hs | 399 +++++++++++++----------------- Database/MySQL/Query.hs | 6 +- mysql-haskell.cabal | 56 ++--- 4 files changed, 210 insertions(+), 269 deletions(-) diff --git a/Database/MySQL/Connection.hs b/Database/MySQL/Connection.hs index fef82b5..8e91641 100644 --- a/Database/MySQL/Connection.hs +++ b/Database/MySQL/Connection.hs @@ -46,23 +46,21 @@ import qualified Data.Connection as TCP -- You shouldn't use one 'MySQLConn' in different thread, if you do that, -- consider protecting it with a @MVar@. -- -data MySQLConn = MySQLConn { - mysqlRead :: {-# UNPACK #-} !(InputStream Packet) - , mysqlWrite :: (Packet -> IO ()) - , mysqlCloseSocket :: IO () - , isConsumed :: {-# UNPACK #-} !(IORef Bool) +data MySQLConn = MySQLConn + { mysqlRead :: IO (Maybe Packet) + , mysqlWrite :: Packet -> IO () + , isConsumed :: {-# UNPACK #-} !(IORef Bool) } -- | Everything you need to establish a MySQL connection. -- --- To setup a TLS connection, use module "Database.MySQL.TLS" or "Database.MySQL.OpenSSL". -- data ConnectInfo = ConnectInfo - { ciHost :: HostName + { ciHost :: CBytes , ciPort :: PortNumber - , ciDatabase :: ByteString - , ciUser :: ByteString - , ciPassword :: ByteString + , ciDatabase :: T.Text + , ciUser :: T.Text + , ciPassword :: T.Text , ciCharset :: Word8 } deriving Show diff --git a/Database/MySQL/Protocol/Packet.hs b/Database/MySQL/Protocol/Packet.hs index 3b160c7..fa5145a 100644 --- a/Database/MySQL/Protocol/Packet.hs +++ b/Database/MySQL/Protocol/Packet.hs @@ -15,61 +15,51 @@ MySQL packet decoder&encoder, and varities utility. module Database.MySQL.Protocol.Packet where -import Control.Applicative -import Control.Exception (Exception (..), throwIO) -import Data.Binary.Parser -import Data.Binary.Put -import Data.Binary (Binary(..), encode) import Data.Bits -import qualified Data.ByteString as B -import Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L -import Data.Int.Int24 -import Data.Int import Data.Word -import Data.Typeable -import Data.Word.Word24 +import GHC.Generics +import Z.IO.Exception +import qualified Z.Data.Parser as P +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Extra as V -------------------------------------------------------------------------------- -- | MySQL packet type -- data Packet = Packet - { pLen :: !Int64 - , pSeqN :: !Word8 - , pBody :: !L.ByteString - } deriving (Show, Eq) - -putPacket :: Packet -> Put -putPacket (Packet len seqN body) = do - putWord24le (fromIntegral len) - putWord8 seqN - putLazyByteString body -{-# INLINE putPacket #-} - -getPacket :: Get Packet -getPacket = do - len <- fromIntegral <$> getWord24le - seqN <- getWord8 - body <- getLazyByteString (fromIntegral len) + { pLen :: {-# UNPACK #-} !Int + , pSeqN :: {-# UNPACK #-} !Word8 + , pBody :: !V.Bytes + } deriving (Show, Eq, Ord, Generic) + deriving anyclass T.Print + +encodePacket :: Packet -> B.Builder () +encodePacket (Packet len seqN body) = do + encodeWord24LE (fromIntegral len) + B.word8 seqN + B.bytes body +{-# INLINE encodePacket #-} + +decodePacket :: P.Parser Packet +decodePacket = do + len <- fromIntegral <$> decodeWord24LE + seqN <- P.anyWord8 + body <- P.take (fromIntegral len) return (Packet len seqN body) -{-# INLINE getPacket #-} - -instance Binary Packet where - put = putPacket - {-# INLINE put #-} - get = getPacket - {-# INLINE get #-} +{-# INLINE decodePacket #-} isERR :: Packet -> Bool -isERR p = L.index (pBody p) 0 == 0xFF +isERR p = V.unsafeIndex (pBody p) 0 == 0xFF {-# INLINE isERR #-} isOK :: Packet -> Bool -isOK p = L.index (pBody p) 0 == 0x00 +isOK p = V.unsafeIndex (pBody p) 0 == 0x00 {-# INLINE isOK #-} isEOF :: Packet -> Bool -isEOF p = L.index (pBody p) 0 == 0xFE +isEOF p = V.unsafeIndex (pBody p) 0 == 0xFE {-# INLINE isEOF #-} -- | Is there more packet to be read? @@ -79,222 +69,181 @@ isThereMore :: OK -> Bool isThereMore p = okStatus p .&. 0x08 /= 0 {-# INLINE isThereMore #-} --- | Decoding packet inside IO, throw 'DecodePacketException' on fail parsing, +-- | Decoding packet inside IO, throw 'OtherError' on fail parsing, -- here we choose stability over correctness by omit incomplete consumed case: -- if we successful parse a packet, then we don't care if there're bytes left. -- -decodeFromPacket :: Binary a => Packet -> IO a -decodeFromPacket = getFromPacket get +decodeFromPacket :: P.Parser a -> Packet -> IO a +decodeFromPacket g (Packet _ _ body) = unwrap "EPARSE" $ P.parse' g body {-# INLINE decodeFromPacket #-} -getFromPacket :: Get a -> Packet -> IO a -getFromPacket g (Packet _ _ body) = case parseDetailLazy g body of - Left (buf, offset, errmsg) -> throwIO (DecodePacketFailed buf offset errmsg) - Right (_, _, r ) -> return r -{-# INLINE getFromPacket #-} - -data DecodePacketException = DecodePacketFailed ByteString ByteOffset String - deriving (Typeable, Show) -instance Exception DecodePacketException -encodeToPacket :: Binary a => Word8 -> a -> Packet +-- Encode a packet with a sequence number +encodeToPacket :: Word8 -> B.Builder () -> Packet encodeToPacket seqN payload = - let s = encode payload - l = L.length s + let s = B.build payload + l = V.length s in Packet (fromIntegral 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 -{-# INLINE putToPacket #-} - -------------------------------------------------------------------------------- -- OK, ERR, EOF --- | You may get interested in 'OK' packet because it provides information about +-- | You may decode interested in 'OK' packet because it provides information about -- successful operations. -- data OK = OK - { okAffectedRows :: !Int -- ^ affected row number - , okLastInsertID :: !Int -- ^ last insert's ID - , okStatus :: !Word16 - , okWarningCnt :: !Word16 - } deriving (Show, Eq) - -getOK :: Get OK -getOK = OK <$ skipN 1 - <*> getLenEncInt - <*> getLenEncInt - <*> getWord16le - <*> getWord16le -{-# INLINE getOK #-} - -putOK :: OK -> Put -putOK (OK row lid stat wcnt) = do - putWord8 0x00 - putLenEncInt row - putLenEncInt lid - putWord16le stat - putWord16le wcnt -{-# INLINE putOK #-} - -instance Binary OK where - get = getOK - {-# INLINE get #-} - put = putOK - {-# INLINE put #-} + { okAffectedRows :: {-# UNPACK #-} !Int -- ^ affected row number + , okLastInsertID :: {-# UNPACK #-} !Int -- ^ last insert's ID + , okStatus :: {-# UNPACK #-} !Word16 + , okWarningCnt :: {-# UNPACK #-} !Word16 + } deriving (Show, Eq, Ord, Generic) + deriving anyclass T.Print + +decodeOK :: P.Parser OK +decodeOK = OK <$ P.skip 1 + <*> decodeLenEncInt + <*> decodeLenEncInt + <*> P.decodePrimLE @Word16 + <*> P.decodePrimLE @Word16 +{-# INLINE decodeOK #-} + +encodeOK :: OK -> B.Builder () +encodeOK (OK row lid stat wcnt) = do + B.word8 0x00 + encodeLenEncInt row + encodeLenEncInt lid + B.encodePrimLE @Word16 stat + B.encodePrimLE @Word16 wcnt +{-# INLINE encodeOK #-} data ERR = ERR - { errCode :: !Word16 - , errState :: !ByteString - , errMsg :: !ByteString - } deriving (Show, Eq) - -getERR :: Get ERR -getERR = ERR <$ skipN 1 - <*> getWord16le - <* skipN 1 - <*> getByteString 5 - <*> getRemainingByteString -{-# INLINE getERR #-} - -putERR :: ERR -> Put -putERR (ERR code stat msg) = do - putWord8 0xFF - putWord16le code - putWord8 35 -- '#' - putByteString stat - putByteString msg -{-# INLINE putERR #-} - -instance Binary ERR where - get = getERR - {-# INLINE get #-} - put = putERR - {-# INLINE put #-} + { errCode :: {-# UNPACK #-} !Word16 + , errState :: !V.Bytes + , errMsg :: !V.Bytes + } deriving (Show, Eq, Ord, Generic) + deriving anyclass T.Print + +decodeERR :: P.Parser ERR +decodeERR = ERR <$ P.skip 1 + <*> P.decodePrimLE @Word16 + <* P.skip 1 + <*> P.take 5 + <*> P.takeRemaining +{-# INLINE decodeERR #-} + +encodeERR :: ERR -> B.Builder () +encodeERR (ERR code stat msg) = do + B.word8 0xFF + B.encodePrimLE @Word16 code + B.word8 35 -- '#' + B.bytes stat + B.bytes msg +{-# INLINE encodeERR #-} data EOF = EOF - { eofWarningCnt :: !Word16 - , eofStatus :: !Word16 - } deriving (Show, Eq) - -getEOF :: Get EOF -getEOF = EOF <$ skipN 1 - <*> getWord16le - <*> getWord16le -{-# INLINE getEOF #-} - -putEOF :: EOF -> Put -putEOF (EOF wcnt stat) = do - putWord8 0xFE - putWord16le wcnt - putWord16le stat -{-# INLINE putEOF #-} - -instance Binary EOF where - get = getEOF - {-# INLINE get #-} - put = putEOF - {-# INLINE put #-} + { eofWarningCnt :: {-# UNPACK #-} !Word16 + , eofStatus :: {-# UNPACK #-} !Word16 + } deriving (Show, Eq, Ord, Generic) + deriving anyclass T.Print + +decodeEOF :: P.Parser EOF +decodeEOF = EOF <$ P.skip 1 + <*> P.decodePrimLE @Word16 + <*> P.decodePrimLE @Word16 +{-# INLINE decodeEOF #-} + +encodeEOF :: EOF -> B.Builder () +encodeEOF (EOF wcnt stat) = do + B.word8 0xFE + B.encodePrimLE @Word16 wcnt + B.encodePrimLE @Word16 stat +{-# INLINE encodeEOF #-} -------------------------------------------------------------------------------- -- Helpers -getByteStringNul :: Get ByteString -getByteStringNul = L.toStrict <$> getLazyByteStringNul -{-# INLINE getByteStringNul #-} - -getRemainingByteString :: Get ByteString -getRemainingByteString = L.toStrict <$> getRemainingLazyByteString -{-# INLINE getRemainingByteString #-} +decodeBytesNul :: P.Parser V.Bytes +decodeBytesNul = P.takeTill (== 0) +{-# INLINE decodeBytesNul #-} -putLenEncBytes :: ByteString -> Put -putLenEncBytes c = do - putLenEncInt (B.length c) - putByteString c -{-# INLINE putLenEncBytes #-} +encodeLenEncBytes :: V.Bytes -> B.Builder () +encodeLenEncBytes c = do + encodeLenEncInt (V.length c) + B.bytes c +{-# INLINE encodeLenEncBytes #-} -getLenEncBytes :: Get ByteString -getLenEncBytes = getLenEncInt >>= getByteString -{-# INLINE getLenEncBytes #-} +decodeLenEncBytes :: P.Parser V.Bytes +decodeLenEncBytes = decodeLenEncInt >>= P.take +{-# INLINE decodeLenEncBytes #-} -- | length encoded int -- https://dev.mysql.com/doc/internals/en/integer.html#packet-Protocol::LengthEncodedInteger -getLenEncInt:: Get Int -getLenEncInt = getWord8 >>= word2Len +decodeLenEncInt:: P.Parser Int +decodeLenEncInt = P.anyWord8 >>= word2Len where word2Len l | l < 0xFB = pure (fromIntegral l) - | l == 0xFC = fromIntegral <$> getWord16le - | l == 0xFD = fromIntegral <$> getWord24le - | l == 0xFE = fromIntegral <$> getWord64le + | l == 0xFC = fromIntegral <$> P.decodePrimLE @Word16 + | l == 0xFD = fromIntegral <$> decodeWord24LE + | l == 0xFE = fromIntegral <$> P.decodePrimLE @Word64 | otherwise = fail $ "invalid length val " ++ show l -{-# INLINE getLenEncInt #-} - -putLenEncInt:: Int -> Put -putLenEncInt x - | x < 251 = putWord8 (fromIntegral x) - | x < 65536 = putWord8 0xFC >> putWord16le (fromIntegral x) - | x < 16777216 = putWord8 0xFD >> putWord24le (fromIntegral x) - | otherwise = putWord8 0xFE >> putWord64le (fromIntegral x) -{-# INLINE putLenEncInt #-} - -putWord24le :: Word32 -> Put -putWord24le v = do - putWord16le $ fromIntegral v - putWord8 $ fromIntegral (v `shiftR` 16) -{-# INLINE putWord24le #-} - -getWord24le :: Get Word32 -getWord24le = do - a <- fromIntegral <$> getWord16le - b <- fromIntegral <$> getWord8 - return $! a .|. (b `shiftL` 16) -{-# INLINE getWord24le #-} - -putWord48le :: Word64 -> Put -putWord48le v = do - putWord32le $ fromIntegral v - putWord16le $ fromIntegral (v `shiftR` 32) -{-# INLINE putWord48le #-} - -getWord48le :: Get Word64 -getWord48le = do - a <- fromIntegral <$> getWord32le - b <- fromIntegral <$> getWord16le - return $! a .|. (b `shiftL` 32) -{-# INLINE getWord48le #-} - -getWord24be :: Get Word24 -getWord24be = do - a <- fromIntegral <$> getWord16be - b <- fromIntegral <$> getWord8 - return $! b .|. (a `shiftL` 8) -{-# INLINE getWord24be #-} - -getInt24be :: Get Int24 -getInt24be = do - a <- fromIntegral <$> getWord16be - b <- fromIntegral <$> getWord8 - return $! fromIntegral $ (b .|. (a `shiftL` 8) :: Word24) -{-# INLINE getInt24be #-} - -getWord40be, getWord48be, getWord56be :: Get Word64 -getWord40be = do - a <- fromIntegral <$> getWord32be - b <- fromIntegral <$> getWord8 - return $! (a `shiftL` 8) .|. b -getWord48be = do - a <- fromIntegral <$> getWord32be - b <- fromIntegral <$> getWord16be - return $! (a `shiftL` 16) .|. b -getWord56be = do - a <- fromIntegral <$> getWord32be - b <- fromIntegral <$> getWord24be - return $! (a `shiftL` 24) .|. b -{-# INLINE getWord40be #-} -{-# INLINE getWord48be #-} -{-# INLINE getWord56be #-} +{-# INLINE decodeLenEncInt #-} + +encodeLenEncInt:: Int -> B.Builder () +encodeLenEncInt x + | x < 251 = B.word8 (fromIntegral x) + | x < 65536 = B.word8 0xFC >> B.encodePrimLE @Word16 (fromIntegral x) + | x < 16777216 = B.word8 0xFD >> encodeWord24LE (fromIntegral x) + | otherwise = B.word8 0xFE >> B.encodePrimLE @Word64 (fromIntegral x) +{-# INLINE encodeLenEncInt #-} + +encodeWord24LE :: Word32 -> B.Builder () +encodeWord24LE v = do + B.encodePrimLE @Word16 $ fromIntegral v + B.word8 $ fromIntegral (v `shiftR` 16) +{-# INLINE encodeWord24LE #-} + +decodeWord24LE :: P.Parser Word32 +decodeWord24LE = do + a <- fromIntegral <$> P.decodePrimLE @Word16 + b <- fromIntegral <$> P.anyWord8 + return $! a .|. (b `unsafeShiftL` 16) +{-# INLINE decodeWord24LE #-} + +encodeWord48LE :: Word64 -> B.Builder () +encodeWord48LE v = do + B.encodePrimLE @Word32 $ fromIntegral v + B.encodePrimLE @Word16 $ fromIntegral (v `shiftR` 32) +{-# INLINE encodeWord48LE #-} + +decodeWord48LE :: P.Parser Word64 +decodeWord48LE = do + a <- fromIntegral <$> P.decodePrimLE @Word32 + b <- fromIntegral <$> P.decodePrimLE @Word16 + return $! a .|. (b `unsafeShiftL` 32) +{-# INLINE decodeWord48LE #-} + +decodeWord24BE :: P.Parser Word32 +decodeWord24BE = do + a <- fromIntegral <$> P.decodePrimBE @Word16 + b <- fromIntegral <$> P.anyWord8 + return $! b .|. (a `unsafeShiftL` 8) +{-# INLINE decodeWord24BE #-} + +decodeWord40BE, decodeWord48BE, decodeWord56BE :: P.Parser Word64 +decodeWord40BE = do + a <- fromIntegral <$> P.decodePrimBE @Word32 + b <- fromIntegral <$> P.anyWord8 + return $! (a `unsafeShiftL` 8) .|. b +decodeWord48BE = do + a <- fromIntegral <$> P.decodePrimBE @Word32 + b <- fromIntegral <$> P.decodePrimBE @Word16 + return $! (a `unsafeShiftL` 16) .|. b +decodeWord56BE = do + a <- fromIntegral <$> P.decodePrimBE @Word32 + b <- fromIntegral <$> decodeWord24BE + return $! (a `unsafeShiftL` 24) .|. b +{-# INLINE decodeWord40BE #-} +{-# INLINE decodeWord48BE #-} +{-# INLINE decodeWord56BE #-} diff --git a/Database/MySQL/Query.hs b/Database/MySQL/Query.hs index 2add90a..a389ff9 100644 --- a/Database/MySQL/Query.hs +++ b/Database/MySQL/Query.hs @@ -3,9 +3,9 @@ module Database.MySQL.Query where import Data.String (IsString (..)) import Control.Exception (throw, Exception) import Data.Typeable -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as LC -import qualified Data.ByteString.Builder as BB +import qualified Z.Data.Builder as B +import qualified Z.Data.Vector as V +import qualified Z.Data.Text as T import Control.Arrow (first) import Database.MySQL.Protocol.MySQLValue import Data.Binary.Put diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal index a50bc44..0d67cfa 100644 --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -1,5 +1,5 @@ name: mysql-haskell -version: 0.8.4.3 +version: 0.9 synopsis: pure haskell MySQL driver description: pure haskell MySQL driver license: BSD3 @@ -19,46 +19,40 @@ source-repository head location: git://github.com/winterland1989/mysql-haskell.git library - exposed-modules: Database.MySQL.Base - , Database.MySQL.TLS - , Database.MySQL.Protocol.Auth - , Database.MySQL.Protocol.Command - , Database.MySQL.Protocol.ColumnDef - , Database.MySQL.Protocol.Packet - , Database.MySQL.Protocol.MySQLValue - , Database.MySQL.Protocol.Escape - , Database.MySQL.BinLog - , Database.MySQL.BinLogProtocol.BinLogEvent - , Database.MySQL.BinLogProtocol.BinLogValue - , Database.MySQL.BinLogProtocol.BinLogMeta - , Database.MySQL.Connection - other-modules: Database.MySQL.Query + exposed-modules: Database.MySQL.Protocol.Packet + + -- Database.MySQL.Base + --, Database.MySQL.TLS + --, Database.MySQL.Protocol.Auth + --, Database.MySQL.Protocol.Command + --, Database.MySQL.Protocol.ColumnDef + --, Database.MySQL.Protocol.Packet + --, Database.MySQL.Protocol.MySQLValue + --, Database.MySQL.Protocol.Escape + --, Database.MySQL.BinLog + --, Database.MySQL.BinLogProtocol.BinLogEvent + --, Database.MySQL.BinLogProtocol.BinLogValue + --, Database.MySQL.BinLogProtocol.BinLogMeta + --, Database.MySQL.Connection + other-modules: + -- Database.MySQL.Query build-depends: base >= 4.7 && < 5 , monad-loops == 0.4.* - , network >= 2.3 && < 4.0 - , io-streams >= 1.2 && < 2.0 - , tcp-streams >= 1.0 && < 1.1 - , wire-streams >= 0.1 - , binary >= 0.8.3 - , binary-ieee754 - , binary-parsers >= 0.2.1 - , bytestring >= 0.10.2.0 - , text >= 1.1 && < 1.3 - , cryptonite == 0.* - , memory >= 0.14.4 && < 0.16 , time >= 1.5.0 , scientific == 0.3.* - , bytestring-lexing == 0.5.* - , blaze-textual == 0.2.* - , word24 >= 1.0 && <= 3.0 - , tls >= 1.3.5 && < 1.6 - , vector >= 0.8 + , Z-Data >= 0.8.1 && < 0.9 + , Z-IO >= 0.8 && < 0.9 + , Z-Botan >= 0.2 && < 0.3 + default-language: Haskell2010 default-extensions: DeriveDataTypeable , DeriveGeneric + , DeriveAnyClass + , DerivingStrategies , MultiWayIf , OverloadedStrings + , TypeApplications ghc-options: -Wall test-suite test From 662143c9458aeb2cbf98f1b42d057da7bdf086cd Mon Sep 17 00:00:00 2001 From: Dong Date: Wed, 30 Jun 2021 16:17:47 +0800 Subject: [PATCH 2/4] Z.Haskell refract --- Database/MySQL/Base.hs | 196 ++--- Database/MySQL/Connection.hs | 247 +++---- Database/MySQL/Protocol/Auth.hs | 167 ++--- Database/MySQL/Protocol/ColumnDef.hs | 227 +++--- Database/MySQL/Protocol/Command.hs | 116 +-- Database/MySQL/Protocol/Escape.hs | 92 +-- Database/MySQL/Protocol/MySQLValue.hs | 694 ++++++++---------- Database/MySQL/Protocol/Packet.hs | 42 +- Database/MySQL/Query.hs | 48 +- cbits/escape.c | 63 ++ mysql-haskell-openssl/ChangeLog.md | 10 - .../Database/MySQL/OpenSSL.hs | 81 -- mysql-haskell-openssl/LICENSE | 30 - mysql-haskell-openssl/Setup.hs | 2 - .../mysql-haskell-openssl.cabal | 36 - mysql-haskell.cabal | 22 +- 16 files changed, 847 insertions(+), 1226 deletions(-) create mode 100644 cbits/escape.c delete mode 100644 mysql-haskell-openssl/ChangeLog.md delete mode 100644 mysql-haskell-openssl/Database/MySQL/OpenSSL.hs delete mode 100644 mysql-haskell-openssl/LICENSE delete mode 100644 mysql-haskell-openssl/Setup.hs delete mode 100644 mysql-haskell-openssl/mysql-haskell-openssl.cabal diff --git a/Database/MySQL/Base.hs b/Database/MySQL/Base.hs index 09f2460..2e74a59 100644 --- a/Database/MySQL/Base.hs +++ b/Database/MySQL/Base.hs @@ -14,7 +14,6 @@ but you shouldn't try to catch them if you don't have a recovery plan, for example: there's no meaning to catch a 'ERRException' during authentication unless you want to try different passwords. By using this library you will meet: - * 'NetworkException': underline network is broken. * 'UnconsumedResultSet': you should consume previous resultset before sending new command. * 'ERRException': you receive a 'ERR' packet when you shouldn't. * 'UnexpectedPacket': you receive a unexpected packet when you shouldn't. @@ -32,7 +31,6 @@ module Database.MySQL.Base , defaultConnectInfoMB4 , connect , connectDetail - , close , ping -- * Direct query , execute @@ -40,15 +38,12 @@ module Database.MySQL.Base , executeMany_ , execute_ , query_ - , queryVector_ , query - , queryVector -- * Prepared query statement , prepareStmt , prepareStmtDetail , executeStmt , queryStmt - , queryStmtVector , closeStmt , resetStmt -- * Helpers @@ -58,13 +53,10 @@ module Database.MySQL.Base , Query(..) , renderParams , command - , Stream.skipToEof -- * Exceptions - , NetworkException(..) , UnconsumedResultSet(..) , ERRException(..) , UnexpectedPacket(..) - , DecodePacketException(..) , WrongParamsCount(..) -- * MySQL protocol , module Database.MySQL.Protocol.Auth @@ -75,9 +67,7 @@ module Database.MySQL.Base ) where import Control.Applicative -import Control.Exception (mask, onException, throwIO) import Control.Monad -import qualified Data.ByteString.Lazy as L import Data.IORef (writeIORef) import Database.MySQL.Connection import Database.MySQL.Protocol.Auth @@ -85,11 +75,11 @@ import Database.MySQL.Protocol.ColumnDef import Database.MySQL.Protocol.Command import Database.MySQL.Protocol.MySQLValue import Database.MySQL.Protocol.Packet - import Database.MySQL.Query -import System.IO.Streams (InputStream) -import qualified System.IO.Streams as Stream -import qualified Data.Vector as V +import Z.Data.ASCII +import qualified Z.Data.Vector as V +import qualified Z.Data.Text as T +import Z.IO -------------------------------------------------------------------------------- @@ -100,11 +90,9 @@ import qualified Data.Vector as V -- and you should consider using prepared statement if this's not an one shot query. -- execute :: QueryParam p => MySQLConn -> Query -> [p] -> IO OK +{-# INLINABLE execute #-} execute conn qry params = execute_ conn (renderParams qry params) -{-# SPECIALIZE execute :: MySQLConn -> Query -> [MySQLValue] -> IO OK #-} -{-# SPECIALIZE execute :: MySQLConn -> Query -> [Param] -> IO OK #-} - -- | Execute a multi-row query which don't return result-set. -- -- Leverage MySQL's multi-statement support to do batch insert\/update\/delete, @@ -114,15 +102,13 @@ execute conn qry params = execute_ conn (renderParams qry params) -- @since 0.2.0.0 -- executeMany :: QueryParam p => MySQLConn -> Query -> [[p]] -> IO [OK] -executeMany conn@(MySQLConn is os _ _) qry paramsList = do +{-# INLINABLE executeMany #-} +executeMany conn@(MySQLConn is os _) qry paramsList = do guardUnconsumed conn - let qry' = L.intercalate ";" $ map (fromQuery . renderParams qry) paramsList + let qry' = V.intercalate ";" $ map (fromQuery . renderParams qry) paramsList writeCommand (COM_QUERY qry') os mapM (\ _ -> waitCommandReply is) paramsList -{-# SPECIALIZE executeMany :: MySQLConn -> Query -> [[MySQLValue]] -> IO [OK] #-} -{-# SPECIALIZE executeMany :: MySQLConn -> Query -> [[Param]] -> IO [OK] #-} - -- | Execute multiple querys (without param) which don't return result-set. -- -- This's useful when your want to execute multiple SQLs without params, e.g. from a @@ -131,7 +117,8 @@ executeMany conn@(MySQLConn is os _ _) qry paramsList = do -- @since 0.8.4.0 -- executeMany_ :: MySQLConn -> Query -> IO [OK] -executeMany_ conn@(MySQLConn is os _ _) qry = do +{-# INLINABLE executeMany_ #-} +executeMany_ conn@(MySQLConn is os _) qry = do guardUnconsumed conn writeCommand (COM_QUERY (fromQuery qry)) os waitCommandReplys is @@ -147,118 +134,76 @@ execute_ conn (Query qry) = command conn (COM_QUERY qry) -- the same 'MySQLConn', or an 'UnconsumedResultSet' will be thrown. -- if you want to skip the result-set, use 'Stream.skipToEof'. -- -query :: QueryParam p => MySQLConn -> Query -> [p] -> IO ([ColumnDef], InputStream [MySQLValue]) +query :: QueryParam p => MySQLConn -> Query -> [p] -> IO (V.Vector ColumnDef, Source (V.Vector MySQLValue)) query conn qry params = query_ conn (renderParams qry params) -{-# SPECIALIZE query :: MySQLConn -> Query -> [MySQLValue] -> IO ([ColumnDef], InputStream [MySQLValue]) #-} -{-# SPECIALIZE query :: MySQLConn -> Query -> [Param] -> IO ([ColumnDef], InputStream [MySQLValue]) #-} - --- | 'V.Vector' version of 'query'. --- --- @since 0.5.1.0 --- -queryVector :: QueryParam p => MySQLConn -> Query -> [p] -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue)) -queryVector conn qry params = queryVector_ conn (renderParams qry params) - -{-# SPECIALIZE queryVector :: MySQLConn -> Query -> [MySQLValue] -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue)) #-} -{-# SPECIALIZE queryVector :: MySQLConn -> Query -> [Param] -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue)) #-} +readFields :: HasCallStack => Int -> BufferedInput -> IO (V.Vector ColumnDef) +{-# INLINABLE readFields #-} +readFields len is = + V.replicateMVec len (decodeFromPacket decodeField =<< readPacket is) -- | Execute a MySQL query which return a result-set. -- -query_ :: MySQLConn -> Query -> IO ([ColumnDef], InputStream [MySQLValue]) -query_ conn@(MySQLConn is os _ consumed) (Query qry) = do +query_ :: HasCallStack => MySQLConn -> Query -> IO (V.Vector ColumnDef, Source (V.Vector MySQLValue)) +query_ conn@(MySQLConn is os consumed) (Query qry) = do guardUnconsumed conn writeCommand (COM_QUERY qry) os p <- readPacket is - if isERR p - then decodeFromPacket p >>= throwIO . ERRException - else do - len <- getFromPacket getLenEncInt p - fields <- replicateM len $ (decodeFromPacket <=< readPacket) is - _ <- readPacket is -- eof packet, we don't verify this though - writeIORef consumed False - rows <- Stream.makeInputStream $ do + len <- decodeFromPacket decodeLenEncInt p + fields <- readFields len is + _ <- readPacket is -- eof packet, we don't verify this though + writeIORef consumed False + let rows = sourceFromIO $ do q <- readPacket is - if | isEOF q -> writeIORef consumed True >> return Nothing - | isERR q -> decodeFromPacket q >>= throwIO . ERRException - | otherwise -> Just <$> getFromPacket (getTextRow fields) q - return (fields, rows) - --- | 'V.Vector' version of 'query_'. --- --- @since 0.5.1.0 --- -queryVector_ :: MySQLConn -> Query -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue)) -queryVector_ conn@(MySQLConn is os _ consumed) (Query qry) = do - guardUnconsumed conn - writeCommand (COM_QUERY qry) os - p <- readPacket is - if isERR p - then decodeFromPacket p >>= throwIO . ERRException - else do - len <- getFromPacket getLenEncInt p - fields <- V.replicateM len $ (decodeFromPacket <=< readPacket) is - _ <- readPacket is -- eof packet, we don't verify this though - writeIORef consumed False - rows <- Stream.makeInputStream $ do - q <- readPacket is - if | isEOF q -> writeIORef consumed True >> return Nothing - | isERR q -> decodeFromPacket q >>= throwIO . ERRException - | otherwise -> Just <$> getFromPacket (getTextRowVector fields) q - return (fields, rows) + if isEOF q + then writeIORef consumed True >> return Nothing + else Just <$> decodeFromPacket (decodeTextRow fields) q + return (fields, rows) -- | Ask MySQL to prepare a query statement. -- -prepareStmt :: MySQLConn -> Query -> IO StmtID -prepareStmt conn@(MySQLConn is os _ _) (Query stmt) = do +prepareStmt :: HasCallStack => MySQLConn -> Query -> IO StmtID +prepareStmt conn@(MySQLConn is os _) (Query stmt) = do guardUnconsumed conn writeCommand (COM_STMT_PREPARE stmt) os p <- readPacket is - if isERR p - then decodeFromPacket p >>= throwIO . ERRException - else do - StmtPrepareOK stid colCnt paramCnt _ <- getFromPacket getStmtPrepareOK p - _ <- replicateM_ paramCnt (readPacket is) - _ <- unless (paramCnt == 0) (void (readPacket is)) -- EOF - _ <- replicateM_ colCnt (readPacket is) - _ <- unless (colCnt == 0) (void (readPacket is)) -- EOF - return stid + StmtPrepareOK stid colCnt paramCnt _ <- decodeFromPacket decodeStmtPrepareOK p + _ <- replicateM_ (fromIntegral paramCnt) (readPacket is) + _ <- unless (paramCnt == 0) (void (readPacket is)) -- EOF + _ <- replicateM_ (fromIntegral colCnt) (readPacket is) + _ <- unless (colCnt == 0) (void (readPacket is)) -- EOF + return stid -- | Ask MySQL to prepare a query statement. -- -- All details from @COM_STMT_PREPARE@ Response are returned: the 'StmtPrepareOK' packet, -- params's 'ColumnDef', result's 'ColumnDef'. -- -prepareStmtDetail :: MySQLConn -> Query -> IO (StmtPrepareOK, [ColumnDef], [ColumnDef]) -prepareStmtDetail conn@(MySQLConn is os _ _) (Query stmt) = do +prepareStmtDetail :: HasCallStack => MySQLConn -> Query -> IO (StmtPrepareOK, V.Vector ColumnDef, V.Vector ColumnDef) +prepareStmtDetail conn@(MySQLConn is os _) (Query stmt) = do guardUnconsumed conn writeCommand (COM_STMT_PREPARE stmt) os p <- readPacket is - if isERR p - then decodeFromPacket p >>= throwIO . ERRException - else do - sOK@(StmtPrepareOK _ colCnt paramCnt _) <- getFromPacket getStmtPrepareOK p - pdefs <- replicateM paramCnt ((decodeFromPacket <=< readPacket) is) - _ <- unless (paramCnt == 0) (void (readPacket is)) -- EOF - cdefs <- replicateM colCnt ((decodeFromPacket <=< readPacket) is) - _ <- unless (colCnt == 0) (void (readPacket is)) -- EOF - return (sOK, pdefs, cdefs) + sOK@(StmtPrepareOK _ colCnt paramCnt _) <- decodeFromPacket decodeStmtPrepareOK p + pdefs <- readFields (fromIntegral paramCnt) is + _ <- unless (paramCnt == 0) (void (readPacket is)) -- EOF + cdefs <- readFields (fromIntegral colCnt) is + _ <- unless (colCnt == 0) (void (readPacket is)) -- EOF + return (sOK, pdefs, cdefs) -- | Ask MySQL to closed a query statement. -- closeStmt :: MySQLConn -> StmtID -> IO () -closeStmt (MySQLConn _ os _ _) stid = do +closeStmt (MySQLConn _ os _) stid = do writeCommand (COM_STMT_CLOSE stid) os -- | Ask MySQL to reset a query statement, all previous resultset will be cleared. -- +-- This function can be used when you want to stop a long running query from another thread. +-- Which will lead a thread running `queryStmt` reach its EOF. resetStmt :: MySQLConn -> StmtID -> IO () -resetStmt (MySQLConn is os _ consumed) stid = do +resetStmt (MySQLConn _ os _) stid = do writeCommand (COM_STMT_RESET stid) os -- previous result-set may still be unconsumed - p <- readPacket is - if isERR p - then decodeFromPacket p >>= throwIO . ERRException - else writeIORef consumed True -- | Execute prepared query statement with parameters, expecting no resultset. -- @@ -270,49 +215,22 @@ executeStmt conn stid params = -- -- Rules about 'UnconsumedResultSet' applied here too. -- -queryStmt :: MySQLConn -> StmtID -> [MySQLValue] -> IO ([ColumnDef], InputStream [MySQLValue]) -queryStmt conn@(MySQLConn is os _ consumed) stid params = do - guardUnconsumed conn - writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os - p <- readPacket is - if isERR p - then decodeFromPacket p >>= throwIO . ERRException - else do - len <- getFromPacket getLenEncInt p - fields <- replicateM len $ (decodeFromPacket <=< readPacket) is - _ <- readPacket is -- eof packet, we don't verify this though - writeIORef consumed False - rows <- Stream.makeInputStream $ do - q <- readPacket is - if | isOK q -> Just <$> getFromPacket (getBinaryRow fields len) q - | isEOF q -> writeIORef consumed True >> return Nothing - | isERR q -> decodeFromPacket q >>= throwIO . ERRException - | otherwise -> throwIO (UnexpectedPacket q) - return (fields, rows) - --- | 'V.Vector' version of 'queryStmt' --- --- @since 0.5.1.0 --- -queryStmtVector :: MySQLConn -> StmtID -> [MySQLValue] -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue)) -queryStmtVector conn@(MySQLConn is os _ consumed) stid params = do +queryStmt :: HasCallStack + => MySQLConn -> StmtID -> [MySQLValue] -> IO (V.Vector ColumnDef, Source (V.Vector MySQLValue)) +queryStmt conn@(MySQLConn is os consumed) stid params = do guardUnconsumed conn writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os p <- readPacket is - if isERR p - then decodeFromPacket p >>= throwIO . ERRException - else do - len <- getFromPacket getLenEncInt p - fields <- V.replicateM len $ (decodeFromPacket <=< readPacket) is - _ <- readPacket is -- eof packet, we don't verify this though - writeIORef consumed False - rows <- Stream.makeInputStream $ do + len <- decodeFromPacket decodeLenEncInt p + fields <- readFields len is + _ <- readPacket is -- eof packet, we don't verify this though + writeIORef consumed False + let rows = sourceFromIO $ do q <- readPacket is - if | isOK q -> Just <$> getFromPacket (getBinaryRowVector fields len) q + if | isOK q -> Just <$> decodeFromPacket (decodeBinaryRow fields len) q | isEOF q -> writeIORef consumed True >> return Nothing - | isERR q -> decodeFromPacket q >>= throwIO . ERRException - | otherwise -> throwIO (UnexpectedPacket q) - return (fields, rows) + | otherwise -> throwIO (UnexpectedPacket q callStack) + return (fields, rows) -- | Run querys inside a transaction, querys will be rolled back if exception arise. -- diff --git a/Database/MySQL/Connection.hs b/Database/MySQL/Connection.hs index 8e91641..4f4b256 100644 --- a/Database/MySQL/Connection.hs +++ b/Database/MySQL/Connection.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-| Module : Database.MySQL.Connection Description : Connection managment @@ -13,31 +14,23 @@ This is an internal module, the 'MySQLConn' type should not directly acessed to module Database.MySQL.Connection where -import Control.Applicative -import Control.Exception (Exception, bracketOnError, - throwIO, catch, SomeException) import Control.Monad -import qualified Crypto.Hash as Crypto -import qualified Data.Binary as Binary -import qualified Data.Binary.Put as Binary import Data.Bits -import qualified Data.ByteArray as BA -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Unsafe as B -import Data.IORef (IORef, newIORef, readIORef, - writeIORef) -import Data.Typeable +import Data.IORef import Data.Word +import GHC.Generics +import qualified Z.Crypto.Hash as Crypto +import Z.Crypto.SafeMem +import qualified Z.Data.Parser as P +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Extra as V +import Z.IO.Network +import Z.IO import Database.MySQL.Protocol.Auth import Database.MySQL.Protocol.Command import Database.MySQL.Protocol.Packet -import Network.Socket (HostName, PortNumber) -import System.IO.Streams (InputStream) -import qualified System.IO.Streams as Stream -import qualified System.IO.Streams.TCP as TCP -import qualified Data.Connection as TCP -------------------------------------------------------------------------------- @@ -47,8 +40,8 @@ import qualified Data.Connection as TCP -- consider protecting it with a @MVar@. -- data MySQLConn = MySQLConn - { mysqlRead :: IO (Maybe Packet) - , mysqlWrite :: Packet -> IO () + { mysqlRead :: !BufferedInput + , mysqlWrite :: !BufferedOutput , isConsumed :: {-# UNPACK #-} !(IORef Bool) } @@ -56,8 +49,9 @@ data MySQLConn = MySQLConn -- -- data ConnectInfo = ConnectInfo - { ciHost :: CBytes - , ciPort :: PortNumber + { ciConfig :: Either IPCClientConfig TCPClientConfig + , ciRecvBufSiz :: Int + , ciSendBufSiz :: Int , ciDatabase :: T.Text , ciUser :: T.Text , ciPassword :: T.Text @@ -72,14 +66,20 @@ data ConnectInfo = ConnectInfo -- with @SELECT id, collation_name FROM information_schema.collations ORDER BY id;@ -- defaultConnectInfo :: ConnectInfo -defaultConnectInfo = ConnectInfo "127.0.0.1" 3306 "" "root" "" utf8_general_ci +defaultConnectInfo = ConnectInfo + (Right defaultTCPClientConfig{ tcpRemoteAddr = SocketAddrIPv4 ipv4Loopback 3306 }) + defaultChunkSize defaultChunkSize + "" "root" "" utf8_general_ci -- | 'defaultConnectInfo' with charset set to @utf8mb4_unicode_ci@ -- -- This is recommanded on any MySQL server version >= 5.5.3. -- defaultConnectInfoMB4 :: ConnectInfo -defaultConnectInfoMB4 = ConnectInfo "127.0.0.1" 3306 "" "root" "" utf8mb4_unicode_ci +defaultConnectInfoMB4 = ConnectInfo + (Right defaultTCPClientConfig{ tcpRemoteAddr = SocketAddrIPv4 ipv4Loopback 3306 }) + defaultChunkSize defaultChunkSize + "" "root" "" utf8mb4_unicode_ci utf8_general_ci :: Word8 utf8_general_ci = 33 @@ -98,85 +98,52 @@ bUFSIZE = 16384 -- | Establish a MySQL connection. -- -connect :: ConnectInfo -> IO MySQLConn +connect :: ConnectInfo -> Resource MySQLConn connect = fmap snd . connectDetail -- | Establish a MySQL connection with 'Greeting' back, so you can find server's version .etc. -- -connectDetail :: ConnectInfo -> IO (Greeting, MySQLConn) -connectDetail (ConnectInfo host port db user pass charset) - = bracketOnError open TCP.close go +connectDetail :: HasCallStack => ConnectInfo -> Resource (Greeting, MySQLConn) +connectDetail (ConnectInfo conf recvBufSiz sendBufSiz db user pass charset) = do + uvs <- either initIPCClient initTCPClient conf + initResource (do + (bi, bo) <- newBufferedIO' uvs recvBufSiz sendBufSiz + p <- readPacket bi + greet <- decodeFromPacket decodeGreeting p + let auth = mkAuth (T.getUTF8Bytes db) (T.getUTF8Bytes user) (T.getUTF8Bytes pass) charset greet + writeBuilder bo $ encodePacket (encodeToPacket 1 (encodeAuth auth)) + flushBuffer bo + _ <- readPacket bi -- OK + consumed <- newIORef True + return (greet, MySQLConn bi bo consumed)) + (\ (_, MySQLConn bi bo _) -> writeCommand COM_QUIT bo >> waitNotMandatoryOK bi) where - open = connectWithBufferSize host port bUFSIZE - go c = do - let is = TCP.source c - is' <- decodeInputStream is - p <- readPacket is' - greet <- decodeFromPacket p - 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 - - 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 + waitNotMandatoryOK bi = catch + (void (waitCommandReply bi)) -- server will either reply an OK packet + ((\ _ -> return ()) :: SomeException -> IO ()) -- or directy close the connection + +mkAuth :: V.Bytes -> V.Bytes -> V.Bytes -> 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 + let salt = greetingSalt1 greet `V.append` greetingSalt2 greet + plugin = greetingAuthPlugin greet + scambleBuf = scramble plugin salt pass + in Auth clientCap clientMaxPacketSize charset user scambleBuf db plugin where - scramble :: ByteString -> ByteString -> ByteString - scramble salt pass' - | B.null pass' = B.empty - | otherwise = B.pack (B.zipWith xor sha1pass withSalt) + scramble :: V.Bytes -> V.Bytes -> V.Bytes -> V.Bytes + scramble plugin salt pass' + | V.null pass' = V.empty + | otherwise = case plugin of + "caching_sha2_password" -> V.zipWith' xor sha2pass salt2 + "mysql_native_password" -> V.zipWith' xor sha1pass salt1 + _ -> "" where sha1pass = sha1 pass' - withSalt = sha1 (salt `B.append` sha1 sha1pass) - - sha1 :: ByteString -> ByteString - sha1 = BA.convert . (Crypto.hash :: ByteString -> Crypto.Digest Crypto.SHA1) - --- | A specialized 'decodeInputStream' here for speed -decodeInputStream :: InputStream ByteString -> IO (InputStream Packet) -decodeInputStream is = Stream.makeInputStream $ do - bs <- Stream.readExactly 4 is - let len = fromIntegral (bs `B.unsafeIndex` 0) - .|. fromIntegral (bs `B.unsafeIndex` 1) `shiftL` 8 - .|. fromIntegral (bs `B.unsafeIndex` 2) `shiftL` 16 - seqN = bs `B.unsafeIndex` 3 - body <- loopRead [] len is - return . Just $ Packet len seqN body - where - loopRead acc 0 _ = return $! L.fromChunks (reverse acc) - loopRead acc k is' = do - bs <- Stream.read is' - case bs of Nothing -> throwIO NetworkException - Just bs' -> do let l = fromIntegral (B.length bs') - if l >= k - then do - let (a, rest) = B.splitAt (fromIntegral k) bs' - unless (B.null rest) (Stream.unRead rest is') - return $! L.fromChunks (reverse (a:acc)) - else do - let k' = k - l - k' `seq` loopRead (bs':acc) k' is' - --- | Close a MySQL connection. --- -close :: MySQLConn -> IO () -close (MySQLConn _ _ closeSocket _) = closeSocket + salt1 = sha1 (salt `V.append` sha1 sha1pass) + sha2pass = sha2 pass' + salt2 = sha1 (salt `V.append` sha2 sha2pass) + + sha1 = unCEBytes . Crypto.hash Crypto.SHA160 + sha2 = unCEBytes . Crypto.hash Crypto.SHA256 + -- | Send a 'COM_PING'. -- @@ -189,67 +156,70 @@ ping = flip command COM_PING -- | Send a 'Command' which don't return a resultSet. -- command :: MySQLConn -> Command -> IO OK -command conn@(MySQLConn is os _ _) cmd = do +command conn@(MySQLConn is os _) cmd = do guardUnconsumed conn writeCommand cmd os waitCommandReply is {-# INLINE command #-} -waitCommandReply :: InputStream Packet -> IO OK +waitCommandReply :: HasCallStack => BufferedInput -> IO OK waitCommandReply is = do p <- readPacket is - if | isERR p -> decodeFromPacket p >>= throwIO . ERRException - | isOK p -> decodeFromPacket p - | otherwise -> throwIO (UnexpectedPacket p) + if isOK p + then decodeFromPacket decodeOK p + else throwIO (UnexpectedPacket p callStack) {-# INLINE waitCommandReply #-} -waitCommandReplys :: InputStream Packet -> IO [OK] +waitCommandReplys :: HasCallStack => BufferedInput -> IO [OK] waitCommandReplys is = do p <- readPacket is - if | isERR p -> decodeFromPacket p >>= throwIO . ERRException - | isOK p -> do ok <- decodeFromPacket p - if isThereMore ok - then (ok :) <$> waitCommandReplys is - else return [ok] - | otherwise -> throwIO (UnexpectedPacket p) + if isOK p + then do ok <- decodeFromPacket decodeOK p + if isThereMore ok + then (ok :) <$> waitCommandReplys is + else return [ok] + else throwIO (UnexpectedPacket p callStack) {-# INLINE waitCommandReplys #-} -readPacket :: InputStream Packet -> IO Packet -readPacket is = Stream.read is >>= maybe - (throwIO NetworkException) - (\ p@(Packet len _ bs) -> if len < 16777215 then return p else go len [bs]) - where - go len acc = Stream.read is >>= maybe - (throwIO NetworkException) - (\ (Packet len' seqN bs) -> do - let len'' = len + len' - acc' = bs:acc - if len' < 16777215 - then return (Packet len'' seqN (L.concat . reverse $ acc')) - else len'' `seq` go len'' acc' - ) +-- | Read a 'Packet' from input. +-- +-- This function will raise 'ERRException' if 'ERR' packet is met. +readPacket :: HasCallStack => BufferedInput -> IO Packet +readPacket bi = do + bs <- readExactly 4 bi + let len = fromIntegral (bs `V.unsafeIndex` 0) + .|. fromIntegral (bs `V.unsafeIndex` 1) `unsafeShiftL` 8 + .|. fromIntegral (bs `V.unsafeIndex` 2) `unsafeShiftL` 16 + seqN = bs `V.unsafeIndex` 3 + body <- readExactly len bi + let p = Packet len seqN body + when (isERR p) $ do + err <- decodeFromPacket decodeERR p + throwIO (ERRException err callStack) + return p {-# INLINE readPacket #-} -writeCommand :: Command -> (Packet -> IO ()) -> IO () -writeCommand a writePacket = let bs = Binary.runPut (putCommand a) in - go (fromIntegral (L.length bs)) 0 bs writePacket +writeCommand :: Command -> BufferedOutput -> IO () +writeCommand a bo = do + let bs = B.buildWith V.smallChunkSize (encodeCommand a) + go (V.length bs) 0 bs + flushBuffer bo where - go len seqN bs writePacket' = do + go !len !seqN !bs = do if len < 16777215 - then writePacket (Packet len seqN bs) + then writeBuilder bo $ encodePacket (Packet len seqN bs) else do - let (bs', rest) = L.splitAt 16777215 bs + let (bs', rest) = V.splitAt 16777215 bs seqN' = seqN + 1 len' = len - 16777215 - - writePacket (Packet 16777215 seqN bs') - seqN' `seq` len' `seq` go len' seqN' rest writePacket' + writeBuilder bo $ encodePacket (Packet 16777215 seqN bs') + go len' seqN' rest {-# INLINE writeCommand #-} -guardUnconsumed :: MySQLConn -> IO () -guardUnconsumed (MySQLConn _ _ _ consumed) = do +guardUnconsumed :: HasCallStack => MySQLConn -> IO () +guardUnconsumed (MySQLConn _ _ consumed) = do c <- readIORef consumed - unless c (throwIO UnconsumedResultSet) + unless c (throwIO (UnconsumedResultSet callStack)) {-# INLINE guardUnconsumed #-} writeIORef' :: IORef a -> a -> IO () @@ -259,15 +229,12 @@ writeIORef' ref x = x `seq` writeIORef ref x -------------------------------------------------------------------------------- -- Exceptions -data NetworkException = NetworkException deriving (Typeable, Show) -instance Exception NetworkException - -data UnconsumedResultSet = UnconsumedResultSet deriving (Typeable, Show) +data UnconsumedResultSet = UnconsumedResultSet CallStack deriving (Show) instance Exception UnconsumedResultSet -data ERRException = ERRException ERR deriving (Typeable, Show) +data ERRException = ERRException ERR CallStack deriving (Show) instance Exception ERRException -data UnexpectedPacket = UnexpectedPacket Packet deriving (Typeable, Show) +data UnexpectedPacket = UnexpectedPacket Packet CallStack deriving (Show) instance Exception UnexpectedPacket diff --git a/Database/MySQL/Protocol/Auth.hs b/Database/MySQL/Protocol/Auth.hs index 87f0fed..5236120 100644 --- a/Database/MySQL/Protocol/Auth.hs +++ b/Database/MySQL/Protocol/Auth.hs @@ -16,16 +16,16 @@ Auth related packet. module Database.MySQL.Protocol.Auth where -import Control.Applicative import Control.Monad -import Data.Binary -import Data.Binary.Get -import Data.Binary.Parser -import Data.Binary.Put -import qualified Data.ByteString as B -import Data.ByteString.Char8 as BC import Data.Bits +import Data.Word import Database.MySQL.Protocol.Packet +import GHC.Generics +import Z.IO.Exception +import qualified Z.Data.Parser as P +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V -------------------------------------------------------------------------------- -- Authentications @@ -54,101 +54,67 @@ import Database.MySQL.Protocol.Packet #define CLIENT_PLUGIN_AUTH_LENENC_CLIENT_DATA 0x00200000 data Greeting = Greeting - { greetingProtocol :: !Word8 - , greetingVersion :: !B.ByteString - , greetingConnId :: !Word32 - , greetingSalt1 :: !B.ByteString - , greetingCaps :: !Word32 - , greetingCharset :: !Word8 - , greetingStatus :: !Word16 - , greetingSalt2 :: !B.ByteString - , greetingAuthPlugin :: !B.ByteString + { greetingProtocol :: {-# UNPACK #-} !Word8 + , greetingVersion :: {-# UNPACK #-} !V.Bytes + , greetingConnId :: {-# UNPACK #-} !Word32 + , greetingSalt1 :: {-# UNPACK #-} !V.Bytes + , greetingCaps :: {-# UNPACK #-} !Word32 + , greetingCharset :: {-# UNPACK #-} !Word8 + , greetingStatus :: {-# UNPACK #-} !Word16 + , greetingSalt2 :: {-# UNPACK #-} !V.Bytes + , greetingAuthPlugin :: {-# UNPACK #-} !V.Bytes } deriving (Show, Eq) -putGreeting :: Greeting -> Put -putGreeting (Greeting pv sv cid salt1 cap charset st salt2 authPlugin) = do - putWord8 pv - putByteString sv - putWord8 0x00 - putWord32le cid - putByteString salt1 - let capL = fromIntegral cap .|. 0xFF - capH = fromIntegral (cap `shiftR` 16) .|. 0xFF - putWord16le capL - putWord8 charset - putWord16le st - putWord16le capH - putWord8 (fromIntegral $ B.length salt2) - replicateM_ 10 (putWord8 0x00) - when (cap .&. CLIENT_SECURE_CONNECTION /= 0) - (putByteString salt2) - when (cap .&. CLIENT_PLUGIN_AUTH /= 0) - (putByteString authPlugin) - -getGreeting :: Get Greeting -getGreeting = do - pv <- getWord8 - sv <- getByteStringNul - cid <- getWord32le - salt1 <- getByteString 8 - skipN 1 -- 0x00 - capL <- getWord16le - charset <- getWord8 - status <- getWord16le - capH <- getWord16le +decodeGreeting :: P.Parser Greeting +decodeGreeting = do + pv <- P.anyWord8 + sv <- decodeBytesNul + cid <- P.decodePrimLE + salt1 <- P.take 8 + P.skip 1 -- 0x00 + capL <- P.decodePrimLE @Word16 + charset <- P.anyWord8 + status <- P.decodePrimLE + capH <- P.decodePrimLE @Word16 let cap = fromIntegral capH `shiftL` 16 .|. fromIntegral capL - authPluginLen <- getWord8 -- this will issue an unused warning, see the notes below - skipN 10 -- 10 * 0x00 + authPluginLen <- P.anyWord8 -- this will issue an unused warning, see the notes below + P.skip 10 -- 10 * 0x00 salt2 <- if (cap .&. CLIENT_SECURE_CONNECTION) == 0 - then pure B.empty - else getByteStringNul -- This is different with the MySQL document here - -- The doc said we should expect a MAX(13, length of auth-plugin-data - 8) - -- length bytes, but doing so stop us from login - -- anyway 'getByteStringNul' works perfectly here. + then pure V.empty + else decodeBytesNul -- This is different with the MySQL document here + -- The doc said we should expect a MAX(13, length of auth-plugin-data - 8) + -- length bytes, but doing so stop us from login + -- anyway 'decodeBytesNul' works perfectly here. authPlugin <- if (cap .&. CLIENT_PLUGIN_AUTH) == 0 - then pure B.empty - else getByteStringNul + then pure V.empty + else decodeBytesNul return (Greeting pv sv cid salt1 cap charset status salt2 authPlugin) -instance Binary Greeting where - get = getGreeting - put = putGreeting - data Auth = Auth - { authCaps :: !Word32 - , authMaxPacket :: !Word32 - , authCharset :: !Word8 - , authName :: !ByteString - , authPassword :: !ByteString - , authSchema :: !ByteString + { authCaps :: {-# UNPACK #-} !Word32 + , authMaxPacket :: {-# UNPACK #-} !Word32 + , authCharset :: {-# UNPACK #-} !Word8 + , authName :: {-# UNPACK #-} !V.Bytes + , authPassword :: {-# UNPACK #-} !V.Bytes -- ^ the auth response + , authSchema :: {-# UNPACK #-} !V.Bytes + , authPlugin :: {-# UNPACK #-} !V.Bytes } deriving (Show, Eq) -getAuth :: Get Auth -getAuth = do - a <- getWord32le - m <- getWord32le - c <- getWord8 - skipN 23 - n <- getByteStringNul - return $ Auth a m c n B.empty B.empty - -putAuth :: Auth -> Put -putAuth (Auth cap m c n p s) = do - putWord32le cap - putWord32le m - putWord8 c - replicateM_ 23 (putWord8 0x00) - putByteString n >> putWord8 0x00 - putWord8 $ fromIntegral (B.length p) - putByteString p - putByteString s - putWord8 0x00 - -instance Binary Auth where - get = getAuth - put = putAuth +encodeAuth :: Auth -> B.Builder () +encodeAuth (Auth cap m c n p s plugin) = do + B.encodePrimLE cap + B.encodePrimLE m + B.word8 c + replicateM_ 23 (B.word8 0x00) + B.bytes n >> B.word8 0x00 + B.word8 $ fromIntegral (V.length p) + B.bytes p + B.bytes s + B.word8 0x00 + B.bytes plugin + B.word8 0x00 data SSLRequest = SSLRequest { sslReqCaps :: !Word32 @@ -156,19 +122,15 @@ data SSLRequest = SSLRequest , sslReqCharset :: !Word8 } deriving (Show, Eq) -getSSLRequest :: Get SSLRequest -getSSLRequest = SSLRequest <$> getWord32le <*> getWord32le <*> getWord8 <* skipN 23 - -putSSLRequest :: SSLRequest -> Put -putSSLRequest (SSLRequest cap m c) = do - putWord32le cap - putWord32le m - putWord8 c - replicateM_ 23 (putWord8 0x00) +decodeSSLRequest :: P.Parser SSLRequest +decodeSSLRequest = SSLRequest <$> P.decodePrimLE <*> P.decodePrimLE <*> P.anyWord8 <* P.skip 23 -instance Binary SSLRequest where - get = getSSLRequest - put = putSSLRequest +encodeSSLRequest :: SSLRequest -> B.Builder () +encodeSSLRequest (SSLRequest cap m c) = do + B.encodePrimLE cap + B.encodePrimLE m + B.word8 c + replicateM_ 23 (B.word8 0x00) -------------------------------------------------------------------------------- -- default Capability Flags @@ -187,7 +149,6 @@ clientCap = CLIENT_LONG_PASSWORD clientMaxPacketSize :: Word32 clientMaxPacketSize = 0x00ffffff :: Word32 - supportTLS :: Word32 -> Bool supportTLS x = (x .&. CLIENT_SSL) /= 0 diff --git a/Database/MySQL/Protocol/ColumnDef.hs b/Database/MySQL/Protocol/ColumnDef.hs index ab3a417..2ea1234 100644 --- a/Database/MySQL/Protocol/ColumnDef.hs +++ b/Database/MySQL/Protocol/ColumnDef.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE PatternSynonyms #-} {-| Module : Database.MySQL.Protocol.ColumnDef @@ -16,13 +16,11 @@ Column definition(aka. field type). module Database.MySQL.Protocol.ColumnDef where -import Control.Applicative -import Data.Binary -import Data.Binary.Get -import Data.Binary.Parser -import Data.Binary.Put -import Data.Bits ((.&.)) -import Data.ByteString (ByteString) +import Data.Word +import Data.Bits +import qualified Z.Data.Parser as P +import qualified Z.Data.Builder as B +import qualified Z.Data.Vector as V import Database.MySQL.Protocol.Packet -------------------------------------------------------------------------------- @@ -30,113 +28,116 @@ import Database.MySQL.Protocol.Packet -- | A description of a field (column) of a table. data ColumnDef = ColumnDef - { -- fieldCatalog :: !ByteString -- ^ const 'def' - columnDB :: !ByteString -- ^ Database for table. - , columnTable :: !ByteString -- ^ Table of column, if column was a field. - , columnOrigTable :: !ByteString -- ^ Original table name, if table was an alias. - , columnName :: !ByteString -- ^ Name of column. - , columnOrigName :: !ByteString -- ^ Original column name, if an alias. - , columnCharSet :: !Word16 -- ^ Character set number. - , columnLength :: !Word32 -- ^ Width of column (create length). - , columnType :: !FieldType - , columnFlags :: !Word16 -- ^ Div flags. - , columnDecimals :: !Word8 -- ^ Number of decimals in field. + { -- fieldCatalog :: !V.Bytes -- ^ const 'def' + columnDB :: {-# UNPACK #-} !V.Bytes -- ^ Database for table. + , columnTable :: {-# UNPACK #-} !V.Bytes -- ^ Table of column, if column was a field. + , columnOrigTable :: {-# UNPACK #-} !V.Bytes -- ^ Original table name, if table was an alias. + , columnName :: {-# UNPACK #-} !V.Bytes -- ^ Name of column. + , columnOrigName :: {-# UNPACK #-} !V.Bytes -- ^ Original column name, if an alias. + , columnCharSet :: {-# UNPACK #-} !Word16 -- ^ Character set number. + , columnLength :: {-# UNPACK #-} !Word32 -- ^ Width of column (create length). + , columnType :: {-# UNPACK #-} !FieldType + , columnFlags :: {-# UNPACK #-} !Word16 -- ^ Div flags. + , columnDecimals :: {-# UNPACK #-} !Word8 -- ^ Number of decimals in field. } deriving (Show, Eq) -getField :: Get ColumnDef -getField = ColumnDef - <$> (skipN 4 -- const "def" - *> getLenEncBytes) -- db - <*> getLenEncBytes -- table - <*> getLenEncBytes -- origTable - <*> getLenEncBytes -- name - <*> getLenEncBytes -- origName - <* skipN 1 -- const 0x0c - <*> getWord16le -- charset - <*> getWord32le -- length - <*> getFieldType -- type - <*> getWord16le -- flags - <*> getWord8 -- decimals - <* skipN 2 -- const 0x00 0x00 -{-# INLINE getField #-} - -putField :: ColumnDef -> Put -putField (ColumnDef db tbl otbl name oname charset len typ flags dec) = do - putLenEncBytes "def" - putLenEncBytes db - putLenEncBytes tbl - putLenEncBytes otbl - putLenEncBytes name - putLenEncBytes oname - putWord16le charset - putWord32le len - putFieldType typ - putWord16le flags - putWord8 dec - putWord16le 0X0000 -{-# INLINE putField #-} - -instance Binary ColumnDef where - get = getField - {-# INLINE get #-} - put = putField - {-# INLINE put #-} - --- | @newtype@ around 'Word8' for represent @MySQL_TYPE@, We don't use sum type here for speed reason. --- -newtype FieldType = FieldType Word8 deriving (Show, Eq) - -mySQLTypeDecimal, mySQLTypeTiny, mySQLTypeShort, mySQLTypeLong, mySQLTypeFloat :: FieldType -mySQLTypeDouble, mySQLTypeNull, mySQLTypeTimestamp, mySQLTypeLongLong, mySQLTypeInt24 :: FieldType -mySQLTypeDate, mySQLTypeTime, mySQLTypeDateTime, mySQLTypeYear, mySQLTypeNewDate, mySQLTypeVarChar :: FieldType -mySQLTypeBit, mySQLTypeTimestamp2, mySQLTypeDateTime2, mySQLTypeTime2, mySQLTypeNewDecimal :: FieldType -mySQLTypeEnum, mySQLTypeSet, mySQLTypeTinyBlob, mySQLTypeMediumBlob, mySQLTypeLongBlob :: FieldType -mySQLTypeBlob, mySQLTypeVarString, mySQLTypeString, mySQLTypeGeometry :: FieldType - -mySQLTypeDecimal = FieldType 0x00 -mySQLTypeTiny = FieldType 0x01 -mySQLTypeShort = FieldType 0x02 -mySQLTypeLong = FieldType 0x03 -mySQLTypeFloat = FieldType 0x04 -mySQLTypeDouble = FieldType 0x05 -mySQLTypeNull = FieldType 0x06 -mySQLTypeTimestamp = FieldType 0x07 -mySQLTypeLongLong = FieldType 0x08 -mySQLTypeInt24 = FieldType 0x09 -mySQLTypeDate = FieldType 0x0a -mySQLTypeTime = FieldType 0x0b -mySQLTypeDateTime = FieldType 0x0c -mySQLTypeYear = FieldType 0x0d -mySQLTypeNewDate = FieldType 0x0e -mySQLTypeVarChar = FieldType 0x0f -mySQLTypeBit = FieldType 0x10 -mySQLTypeTimestamp2 = FieldType 0x11 -mySQLTypeDateTime2 = FieldType 0x12 -mySQLTypeTime2 = FieldType 0x13 -mySQLTypeNewDecimal = FieldType 0xf6 -mySQLTypeEnum = FieldType 0xf7 -mySQLTypeSet = FieldType 0xf8 -mySQLTypeTinyBlob = FieldType 0xf9 -mySQLTypeMediumBlob = FieldType 0xfa -mySQLTypeLongBlob = FieldType 0xfb -mySQLTypeBlob = FieldType 0xfc -mySQLTypeVarString = FieldType 0xfd -mySQLTypeString = FieldType 0xfe -mySQLTypeGeometry = FieldType 0xff - -getFieldType :: Get FieldType -getFieldType = FieldType <$> getWord8 -{-# INLINE getFieldType #-} - -putFieldType :: FieldType -> Put -putFieldType (FieldType t) = putWord8 t -{-# INLINE putFieldType #-} - -instance Binary FieldType where - get = getFieldType - {-# INLINE get #-} - put = putFieldType - {-# INLINE put #-} +decodeField :: P.Parser ColumnDef +{-# INLINE decodeField #-} +decodeField = ColumnDef + <$> (P.skip 4 -- const "def" + *> decodeLenEncBytes) -- db + <*> decodeLenEncBytes -- table + <*> decodeLenEncBytes -- origTable + <*> decodeLenEncBytes -- name + <*> decodeLenEncBytes -- origName + <* P.skip 1 -- const 0x0c + <*> P.decodePrimLE -- charset + <*> P.decodePrimLE -- length + <*> P.decodePrim -- type + <*> P.decodePrimLE -- flags + <*> P.decodePrim -- decimals + <* P.skip 2 -- const 0x00 0x00 + +encodeField :: ColumnDef -> B.Builder () +{-# INLINE encodeField #-} +encodeField (ColumnDef db tbl otbl name oname charset len typ flags dec) = do + encodeLenEncBytes "def" + encodeLenEncBytes db + encodeLenEncBytes tbl + encodeLenEncBytes otbl + encodeLenEncBytes name + encodeLenEncBytes oname + B.encodePrimLE charset + B.encodePrimLE len + B.encodePrim typ + B.encodePrimLE flags + B.encodePrim dec + B.encodePrimLE @Word16 0X0000 + +-- | MySQL_TYPE +type FieldType = Word8 + +pattern MySQLTypeDecimal :: FieldType +pattern MySQLTypeTiny :: FieldType +pattern MySQLTypeShort :: FieldType +pattern MySQLTypeLong :: FieldType +pattern MySQLTypeFloat :: FieldType +pattern MySQLTypeDouble :: FieldType +pattern MySQLTypeNull :: FieldType +pattern MySQLTypeTimestamp :: FieldType +pattern MySQLTypeLongLong :: FieldType +pattern MySQLTypeInt24 :: FieldType +pattern MySQLTypeDate :: FieldType +pattern MySQLTypeTime :: FieldType +pattern MySQLTypeDateTime :: FieldType +pattern MySQLTypeYear :: FieldType +pattern MySQLTypeNewDate :: FieldType +pattern MySQLTypeVarChar :: FieldType +pattern MySQLTypeBit :: FieldType +pattern MySQLTypeTimestamp2 :: FieldType +pattern MySQLTypeDateTime2 :: FieldType +pattern MySQLTypeTime2 :: FieldType +pattern MySQLTypeNewDecimal :: FieldType +pattern MySQLTypeEnum :: FieldType +pattern MySQLTypeSet :: FieldType +pattern MySQLTypeTinyBlob :: FieldType +pattern MySQLTypeMediumBlob :: FieldType +pattern MySQLTypeLongBlob :: FieldType +pattern MySQLTypeBlob :: FieldType +pattern MySQLTypeVarString :: FieldType +pattern MySQLTypeString :: FieldType +pattern MySQLTypeGeometry :: FieldType + +pattern MySQLTypeDecimal = 0x00 +pattern MySQLTypeTiny = 0x01 +pattern MySQLTypeShort = 0x02 +pattern MySQLTypeLong = 0x03 +pattern MySQLTypeFloat = 0x04 +pattern MySQLTypeDouble = 0x05 +pattern MySQLTypeNull = 0x06 +pattern MySQLTypeTimestamp = 0x07 +pattern MySQLTypeLongLong = 0x08 +pattern MySQLTypeInt24 = 0x09 +pattern MySQLTypeDate = 0x0a +pattern MySQLTypeTime = 0x0b +pattern MySQLTypeDateTime = 0x0c +pattern MySQLTypeYear = 0x0d +pattern MySQLTypeNewDate = 0x0e +pattern MySQLTypeVarChar = 0x0f +pattern MySQLTypeBit = 0x10 +pattern MySQLTypeTimestamp2 = 0x11 +pattern MySQLTypeDateTime2 = 0x12 +pattern MySQLTypeTime2 = 0x13 +pattern MySQLTypeNewDecimal = 0xf6 +pattern MySQLTypeEnum = 0xf7 +pattern MySQLTypeSet = 0xf8 +pattern MySQLTypeTinyBlob = 0xf9 +pattern MySQLTypeMediumBlob = 0xfa +pattern MySQLTypeLongBlob = 0xfb +pattern MySQLTypeBlob = 0xfc +pattern MySQLTypeVarString = 0xfd +pattern MySQLTypeString = 0xfe +pattern MySQLTypeGeometry = 0xff -------------------------------------------------------------------------------- -- Field flags diff --git a/Database/MySQL/Protocol/Command.hs b/Database/MySQL/Protocol/Command.hs index 61c4579..bf88f46 100644 --- a/Database/MySQL/Protocol/Command.hs +++ b/Database/MySQL/Protocol/Command.hs @@ -15,16 +15,18 @@ Common MySQL commands supports. module Database.MySQL.Protocol.Command where -import Control.Applicative import Control.Monad -import Data.Binary -import Data.Binary.Get -import Data.Binary.Parser -import Data.Binary.Put -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as L +import Data.Bits +import Data.Word import Database.MySQL.Protocol.MySQLValue import Database.MySQL.Protocol.Packet +import GHC.Generics +import Z.IO.Exception +import qualified Z.Data.Parser as P +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Extra as V -------------------------------------------------------------------------------- -- Commands @@ -35,55 +37,55 @@ type StmtID = Word32 -- data Command = COM_QUIT -- ^ 0x01 - | COM_INIT_DB !ByteString -- ^ 0x02 - | COM_QUERY !L.ByteString -- ^ 0x03 + | COM_INIT_DB !V.Bytes -- ^ 0x02 + | COM_QUERY !V.Bytes -- ^ 0x03 | COM_PING -- ^ 0x0E - | COM_BINLOG_DUMP !Word32 !Word16 !Word32 !ByteString -- ^ 0x12 + | COM_BINLOG_DUMP !Word32 !Word16 !Word32 !V.Bytes -- ^ 0x12 -- binlog-pos, flags(0x01), server-id, binlog-filename - | COM_REGISTER_SLAVE !Word32 !ByteString !ByteString !ByteString !Word16 !Word32 !Word32 -- ^ 0x15 + | COM_REGISTER_SLAVE !Word32 !V.Bytes !V.Bytes !V.Bytes !Word16 !Word32 !Word32 -- ^ 0x15 -- server-id, slaves hostname, slaves user, slaves password, slaves port, replication rank(ignored), master-id(usually 0) - | COM_STMT_PREPARE !L.ByteString -- ^ 0x16 statement + | COM_STMT_PREPARE !V.Bytes -- ^ 0x16 statement | COM_STMT_EXECUTE !StmtID ![MySQLValue] !BitMap -- ^ 0x17 stmtId, params | COM_STMT_CLOSE !StmtID -- ^ 0x19 stmtId | COM_STMT_RESET !StmtID -- ^ 0x1A stmtId | COM_UNSUPPORTED deriving (Show, Eq) -putCommand :: Command -> Put -putCommand COM_QUIT = putWord8 0x01 -putCommand (COM_INIT_DB db) = putWord8 0x02 >> putByteString db -putCommand (COM_QUERY q) = putWord8 0x03 >> putLazyByteString q -putCommand COM_PING = putWord8 0x0E -putCommand (COM_BINLOG_DUMP pos flags sid fname) = do - putWord8 0x12 - putWord32le pos - putWord16le flags - putWord32le sid - putByteString fname -putCommand (COM_REGISTER_SLAVE sid shost susr spass sport rrank mid) = do - putWord8 0x15 - putWord32le sid - putLenEncBytes shost - putLenEncBytes susr - putLenEncBytes spass - putWord16le sport - putWord32le rrank - putWord32le mid -putCommand (COM_STMT_PREPARE stmt) = putWord8 0x16 >> putLazyByteString stmt -putCommand (COM_STMT_EXECUTE stid params nullmap) = do - putWord8 0x17 - putWord32le stid - putWord8 0x00 -- we only use @CURSOR_TYPE_NO_CURSOR@ here - putWord32le 1 -- const 1 +encodeCommand :: Command -> B.Builder () +encodeCommand COM_QUIT = B.word8 0x01 +encodeCommand (COM_INIT_DB db) = B.word8 0x02 >> B.bytes db +encodeCommand (COM_QUERY q) = B.word8 0x03 >> B.bytes q +encodeCommand COM_PING = B.word8 0x0E +encodeCommand (COM_BINLOG_DUMP pos flags sid fname) = do + B.word8 0x12 + B.encodePrimLE pos + B.encodePrimLE flags + B.encodePrimLE sid + B.bytes fname +encodeCommand (COM_REGISTER_SLAVE sid shost susr spass sport rrank mid) = do + B.word8 0x15 + B.encodePrimLE sid + encodeLenEncBytes shost + encodeLenEncBytes susr + encodeLenEncBytes spass + B.encodePrimLE sport + B.encodePrimLE rrank + B.encodePrimLE mid +encodeCommand (COM_STMT_PREPARE stmt) = B.word8 0x16 >> B.bytes stmt +encodeCommand (COM_STMT_EXECUTE stid params nullmap) = do + B.word8 0x17 + B.encodePrimLE stid + B.word8 0x00 -- we only use @CURSOR_TYPE_NO_CURSOR@ here + B.encodePrimLE @Word32 1 -- const 1 unless (null params) $ do - putByteString (fromBitMap nullmap) - putWord8 0x01 -- always use new-params-bound-flag - mapM_ putParamMySQLType params - forM_ params putBinaryField + B.bytes (fromBitMap nullmap) + B.word8 0x01 -- always use new-params-bound-flag + mapM_ encodeParamMySQLType params + forM_ params encodeBinaryField -putCommand (COM_STMT_CLOSE stid) = putWord8 0x19 >> putWord32le stid -putCommand (COM_STMT_RESET stid) = putWord8 0x1A >> putWord32le stid -putCommand _ = error "unsupported command" +encodeCommand (COM_STMT_CLOSE stid) = B.word8 0x19 >> B.encodePrimLE stid +encodeCommand (COM_STMT_RESET stid) = B.word8 0x1A >> B.encodePrimLE stid +encodeCommand _ = error "unsupported command" -------------------------------------------------------------------------------- -- Prepared statment related @@ -91,18 +93,18 @@ putCommand _ = error "unsupported command" -- | call 'isOK' with this packet return true data StmtPrepareOK = StmtPrepareOK { stmtId :: !StmtID - , stmtColumnCnt :: !Int - , stmtParamCnt :: !Int - , stmtWarnCnt :: !Int + , stmtColumnCnt :: !Word16 + , stmtParamCnt :: !Word16 + , stmtWarnCnt :: !Word16 } deriving (Show, Eq) -getStmtPrepareOK :: Get StmtPrepareOK -getStmtPrepareOK = do - skipN 1 -- OK byte - stmtid <- getWord32le - cc <- fromIntegral <$> getWord16le - pc <- fromIntegral <$> getWord16le - skipN 1 -- reserved - wc <- fromIntegral <$> getWord16le +decodeStmtPrepareOK :: P.Parser StmtPrepareOK +{-# INLINE decodeStmtPrepareOK #-} +decodeStmtPrepareOK = do + P.skipWord8 -- OK byte + stmtid <- P.decodePrimLE + cc <- P.decodePrimLE + pc <- P.decodePrimLE + P.skipWord8 -- reserved + wc <- P.decodePrimLE return (StmtPrepareOK stmtid cc pc wc) -{-# INLINE getStmtPrepareOK #-} diff --git a/Database/MySQL/Protocol/Escape.hs b/Database/MySQL/Protocol/Escape.hs index cc94b57..2a467be 100644 --- a/Database/MySQL/Protocol/Escape.hs +++ b/Database/MySQL/Protocol/Escape.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} {-| Module : Database.MySQL.Protocol.Escape @@ -32,76 +34,22 @@ The @\%@ and @\_@ sequences are used to search for literal instances of @%@ and module Database.MySQL.Protocol.Escape where -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as B -import Data.Text (Text) -import qualified Data.Text.Array as TA -import qualified Data.Text.Internal as T +import Data.Bits import Data.Word -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr, minusPtr, plusPtr) -import Foreign.Storable (peek, poke, pokeByteOff) -import GHC.IO (unsafeDupablePerformIO) - -escapeText :: Text -> Text -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) - TA.unsafeWrite marr ix' c - TA.unsafeWrite marr (ix'+1) c2 - loop oarr oend marr (ix+2) (ix'+2) - | 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 -> TA.unsafeWrite marr ix' c >> go1 - -escapeBytes :: ByteString -> ByteString -escapeBytes (B.PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \ a -> - B.createUptoN (len * 2) $ \ b -> do - b' <- loop (a `plusPtr` s) (a `plusPtr` s `plusPtr` len) b - return (b' `minusPtr` b) - where - escape :: Word8 -> Ptr Word8 -> IO (Ptr Word8) - escape c p = do - poke p 92 - pokeByteOff p 1 c - return (p `plusPtr` 2) - - loop !a aend !b - | a == aend = return b - | otherwise = do - c <- peek a - if | c == 0 - || c == 39 - || c == 34 -> escape c b >>= loop (a `plusPtr` 1) aend -- \0 \' \" - | c == 8 -> escape 98 b >>= loop (a `plusPtr` 1) aend -- \b - | c == 10 -> escape 110 b >>= loop (a `plusPtr` 1) aend -- \n - | c == 13 -> escape 114 b >>= loop (a `plusPtr` 1) aend -- \r - | c == 9 -> escape 116 b >>= loop (a `plusPtr` 1) aend -- \t - | c == 26 -> escape 90 b >>= loop (a `plusPtr` 1) aend -- \Z - | c == 92 -> escape 92 b >>= loop (a `plusPtr` 1) aend -- \\ - - | otherwise -> poke b c >> loop (a `plusPtr` 1) aend (b `plusPtr` 1) +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V +import Z.Foreign + +escapeText :: T.Text -> B.Builder () +escapeText = escapeBytes . T.getUTF8Bytes + +escapeBytes :: V.Bytes -> B.Builder () +escapeBytes v = + B.ensureN (V.length v `unsafeShiftL` 2) $ \ (MutablePrimArray mba) moff -> + withPrimVectorUnsafe v $ \ ba off len -> + escape_mysql_string ba off len mba moff + +foreign import ccall unsafe escape_mysql_string :: BA# Word8 -> Int -> Int + -> MBA# Word8 -> Int + -> IO Int diff --git a/Database/MySQL/Protocol/MySQLValue.hs b/Database/MySQL/Protocol/MySQLValue.hs index b8d6141..8d6908b 100644 --- a/Database/MySQL/Protocol/MySQLValue.hs +++ b/Database/MySQL/Protocol/MySQLValue.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| Module : Database.MySQL.Protocol.MySQLValue @@ -16,57 +16,44 @@ Core text and binary row decoder/encoder machinery. module Database.MySQL.Protocol.MySQLValue ( -- * MySQLValue decoder and encoder MySQLValue(..) - , putParamMySQLType - , getTextField - , putTextField - , getTextRow - , getTextRowVector - , getBinaryField - , putBinaryField - , getBinaryRow - , getBinaryRowVector + , encodeParamMySQLType + , decodeTextField + , encodeTextField + , decodeTextRow + , decodeBinaryField + , encodeBinaryField + , decodeBinaryRow -- * Internal utilities - , getBits + , decodeBits , BitMap(..) , isColumnSet , isColumnNull , makeNullMap ) 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 -import qualified Data.ByteString.Builder as BB -import Data.ByteString.Builder.Scientific (FPFormat (..), - formatScientificBuilder) -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lex.Fractional as LexFrac -import qualified Data.ByteString.Lex.Integral as LexInt -import qualified Data.ByteString.Unsafe as B -import Data.Fixed (Pico) +import Data.Fixed (Pico) import Data.Int -import Data.Scientific (Scientific) -import Data.Text (Text) -import qualified Data.Text.Encoding as T -import Data.Time.Calendar (Day, fromGregorian, - toGregorian) -import Data.Time.Format (defaultTimeLocale, - formatTime) -import Data.Time.LocalTime (LocalTime (..), - TimeOfDay (..)) +import Data.Scientific (Scientific) +import Data.Time.Calendar (Day, fromGregorian, + toGregorian) +import Data.Time.Format (defaultTimeLocale, + formatTime) +import Data.Time.LocalTime (LocalTime (..), + TimeOfDay (..)) +import Data.Word import Data.Word import Database.MySQL.Protocol.ColumnDef import Database.MySQL.Protocol.Escape import Database.MySQL.Protocol.Packet -import GHC.Generics (Generic) -import qualified Data.Vector as V +import GHC.Generics (Generic) +import qualified Z.Data.Builder as B +import qualified Z.Data.Parser as P +import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Extra as V -------------------------------------------------------------------------------- -- | Data type mapping between MySQL values and haskell values. @@ -76,11 +63,11 @@ import qualified Data.Vector as V -- MySQL's @DATETIME@ and @TIMESTAMP@ are different on timezone handling: -- -- * DATETIME and DATE is just a represent of a calendar date, it has no timezone information involved, --- you always get the same value as you put no matter what timezone you're using with MySQL. +-- you always decode the same value as you put no matter what timezone you're using with MySQL. -- -- * MySQL converts TIMESTAMP values from the current time zone to UTC for storage, -- and back from UTC to the current time zone for retrieval. If you put a TIMESTAMP with timezone A, --- then read it with timezone B, you may get different result because of this conversion, so always +-- then read it with timezone B, you may decode different result because of this conversion, so always -- be careful about setting up the right timezone with MySQL, you can do it with a simple @SET time_zone = timezone;@ -- for more info on timezone support, please read -- @@ -88,423 +75,379 @@ import qualified Data.Vector as V -- -- MySQL's @TIME@ type can present time of day, but also elapsed time or a time interval between two events. -- @TIME@ values may range from @-838:59:59@ to @838:59:59@, so 'MySQLTime' values consist of a sign and a --- 'TimeOfDay' whose hour part may exceeded 24. you can use @timeOfDayToTime@ to get the absolute time interval. +-- 'TimeOfDay' whose hour part may exceeded 24. you can use @timeOfDayToTime@ to decode the absolute time interval. -- -- Under MySQL >= 5.7, @DATETIME@, @TIMESTAMP@ and @TIME@ may contain fractional part, which matches haskell's -- precision. -- data MySQLValue - = MySQLDecimal !Scientific -- ^ DECIMAL, NEWDECIMAL - | MySQLInt8U !Word8 -- ^ Unsigned TINY - | MySQLInt8 !Int8 -- ^ TINY - | MySQLInt16U !Word16 -- ^ Unsigned SHORT - | MySQLInt16 !Int16 -- ^ SHORT - | MySQLInt32U !Word32 -- ^ Unsigned LONG, INT24 - | MySQLInt32 !Int32 -- ^ LONG, INT24 - | MySQLInt64U !Word64 -- ^ Unsigned LONGLONG - | MySQLInt64 !Int64 -- ^ LONGLONG - | MySQLFloat !Float -- ^ IEEE 754 single precision format - | MySQLDouble !Double -- ^ IEEE 754 double precision format - | MySQLYear !Word16 -- ^ YEAR - | MySQLDateTime !LocalTime -- ^ DATETIME - | MySQLTimeStamp !LocalTime -- ^ TIMESTAMP - | MySQLDate !Day -- ^ DATE - | MySQLTime !Word8 !TimeOfDay -- ^ sign(0 = non-negative, 1 = negative) hh mm ss microsecond - -- The sign is OPPOSITE to binlog one !!! - | MySQLGeometry !ByteString -- ^ todo: parsing to something meanful - | MySQLBytes !ByteString - | MySQLBit !Word64 - | MySQLText !Text + = MySQLDecimal {-# UNAPCK #-} !Scientific -- ^ DECIMAL, NEWDECIMAL + | MySQLInt8U {-# UNAPCK #-} !Word8 -- ^ Unsigned TINY + | MySQLInt8 {-# UNAPCK #-} !Int8 -- ^ TINY + | MySQLInt16U {-# UNAPCK #-} !Word16 -- ^ Unsigned SHORT + | MySQLInt16 {-# UNAPCK #-} !Int16 -- ^ SHORT + | MySQLInt32U {-# UNAPCK #-} !Word32 -- ^ Unsigned LONG, INT24 + | MySQLInt32 {-# UNAPCK #-} !Int32 -- ^ LONG, INT24 + | MySQLInt64U {-# UNAPCK #-} !Word64 -- ^ Unsigned LONGLONG + | MySQLInt64 {-# UNAPCK #-} !Int64 -- ^ LONGLONG + | MySQLFloat {-# UNAPCK #-} !Float -- ^ IEEE 754 single precision format + | MySQLDouble {-# UNAPCK #-} !Double -- ^ IEEE 754 double precision format + | MySQLYear {-# UNAPCK #-} !Word16 -- ^ YEAR + | MySQLDateTime {-# UNAPCK #-} !LocalTime -- ^ DATETIME + | MySQLTimeStamp {-# UNAPCK #-} !LocalTime -- ^ TIMESTAMP + | MySQLDate {-# UNAPCK #-} !Day -- ^ DATE + | MySQLTime {-# UNAPCK #-} !Word8 -- ^ sign(0 = non-negative, 1 = negative), the sign is OPPOSITE to binlog one !!! + !TimeOfDay -- ^ hh mm ss microsecond + | MySQLGeometry {-# UNPACK #-} !V.Bytes -- ^ todo: parsing to something meanful + | MySQLBytes {-# UNPACK #-} !V.Bytes + | MySQLBit {-# UNPACK #-} !Word64 + | MySQLText {-# UNPACK #-} !T.Text | MySQLNull deriving (Show, Eq, Generic) -- | Put 'FieldType' and usigned bit(0x80/0x00) for 'MySQLValue's. -- -putParamMySQLType :: MySQLValue -> Put -putParamMySQLType (MySQLDecimal _) = putFieldType mySQLTypeDecimal >> putWord8 0x00 -putParamMySQLType (MySQLInt8U _) = putFieldType mySQLTypeTiny >> putWord8 0x80 -putParamMySQLType (MySQLInt8 _) = putFieldType mySQLTypeTiny >> putWord8 0x00 -putParamMySQLType (MySQLInt16U _) = putFieldType mySQLTypeShort >> putWord8 0x80 -putParamMySQLType (MySQLInt16 _) = putFieldType mySQLTypeShort >> putWord8 0x00 -putParamMySQLType (MySQLInt32U _) = putFieldType mySQLTypeLong >> putWord8 0x80 -putParamMySQLType (MySQLInt32 _) = putFieldType mySQLTypeLong >> putWord8 0x00 -putParamMySQLType (MySQLInt64U _) = putFieldType mySQLTypeLongLong >> putWord8 0x80 -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 (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 (MySQLText _) = putFieldType mySQLTypeString >> putWord8 0x00 -putParamMySQLType MySQLNull = putFieldType mySQLTypeNull >> putWord8 0x00 +encodeParamMySQLType :: MySQLValue -> B.Builder () +encodeParamMySQLType (MySQLDecimal _) = B.encodePrim (MySQLTypeDecimal , 0x00::Word8) +encodeParamMySQLType (MySQLInt8U _) = B.encodePrim (MySQLTypeTiny , 0x80::Word8) +encodeParamMySQLType (MySQLInt8 _) = B.encodePrim (MySQLTypeTiny , 0x00::Word8) +encodeParamMySQLType (MySQLInt16U _) = B.encodePrim (MySQLTypeShort , 0x80::Word8) +encodeParamMySQLType (MySQLInt16 _) = B.encodePrim (MySQLTypeShort , 0x00::Word8) +encodeParamMySQLType (MySQLInt32U _) = B.encodePrim (MySQLTypeLong , 0x80::Word8) +encodeParamMySQLType (MySQLInt32 _) = B.encodePrim (MySQLTypeLong , 0x00::Word8) +encodeParamMySQLType (MySQLInt64U _) = B.encodePrim (MySQLTypeLongLong , 0x80::Word8) +encodeParamMySQLType (MySQLInt64 _) = B.encodePrim (MySQLTypeLongLong , 0x00::Word8) +encodeParamMySQLType (MySQLFloat _) = B.encodePrim (MySQLTypeFloat , 0x00::Word8) +encodeParamMySQLType (MySQLDouble _) = B.encodePrim (MySQLTypeDouble , 0x00::Word8) +encodeParamMySQLType (MySQLYear _) = B.encodePrim (MySQLTypeYear , 0x80::Word8) +encodeParamMySQLType (MySQLDateTime _) = B.encodePrim (MySQLTypeDateTime , 0x00::Word8) +encodeParamMySQLType (MySQLTimeStamp _) = B.encodePrim (MySQLTypeTimestamp, 0x00::Word8) +encodeParamMySQLType (MySQLDate _) = B.encodePrim (MySQLTypeDate , 0x00::Word8) +encodeParamMySQLType (MySQLTime _ _) = B.encodePrim (MySQLTypeTime , 0x00::Word8) +encodeParamMySQLType (MySQLBytes _) = B.encodePrim (MySQLTypeBlob , 0x00::Word8) +encodeParamMySQLType (MySQLGeometry _) = B.encodePrim (MySQLTypeGeometry , 0x00::Word8) +encodeParamMySQLType (MySQLBit _) = B.encodePrim (MySQLTypeBit , 0x00::Word8) +encodeParamMySQLType (MySQLText _) = B.encodePrim (MySQLTypeString , 0x00::Word8) +encodeParamMySQLType MySQLNull = B.encodePrim (MySQLTypeNull , 0x00::Word8) -------------------------------------------------------------------------------- -- | Text protocol decoder -getTextField :: ColumnDef -> Get MySQLValue -getTextField f - | t == mySQLTypeNull = pure MySQLNull - | t == mySQLTypeDecimal - || t == mySQLTypeNewDecimal = feedLenEncBytes t MySQLDecimal fracLexer - | t == mySQLTypeTiny = if isUnsigned then feedLenEncBytes t MySQLInt8U intLexer - else feedLenEncBytes t MySQLInt8 intLexer - | t == mySQLTypeShort = if isUnsigned then feedLenEncBytes t MySQLInt16U intLexer - else feedLenEncBytes t MySQLInt16 intLexer - | t == mySQLTypeLong - || t == mySQLTypeInt24 = if isUnsigned then feedLenEncBytes t MySQLInt32U intLexer - else feedLenEncBytes t MySQLInt32 intLexer - | t == mySQLTypeLongLong = if isUnsigned then feedLenEncBytes t MySQLInt64U intLexer - else feedLenEncBytes t MySQLInt64 intLexer - | t == mySQLTypeFloat = feedLenEncBytes t MySQLFloat fracLexer - | t == mySQLTypeDouble = feedLenEncBytes t MySQLDouble fracLexer - | t == mySQLTypeYear = feedLenEncBytes t MySQLYear intLexer - | t == mySQLTypeTimestamp - || t == mySQLTypeTimestamp2 = feedLenEncBytes t MySQLTimeStamp $ \ bs -> - LocalTime <$> dateParser bs <*> timeParser (B.unsafeDrop 11 bs) - | t == mySQLTypeDateTime - || t == mySQLTypeDateTime2 = feedLenEncBytes t MySQLDateTime $ \ bs -> - LocalTime <$> dateParser bs <*> timeParser (B.unsafeDrop 11 bs) - | t == mySQLTypeDate - || t == mySQLTypeNewDate = feedLenEncBytes t MySQLDate dateParser - | t == mySQLTypeTime - || t == mySQLTypeTime2 = feedLenEncBytes t id $ \ bs -> - if bs `B.unsafeIndex` 0 == 45 -- '-' - then MySQLTime 1 <$> timeParser (B.unsafeDrop 1 bs) - else MySQLTime 0 <$> timeParser bs - - | t == mySQLTypeGeometry = MySQLGeometry <$> getLenEncBytes - | t == mySQLTypeVarChar - || t == mySQLTypeEnum - || t == mySQLTypeSet - || t == mySQLTypeTinyBlob - || t == mySQLTypeMediumBlob - || t == mySQLTypeLongBlob - || t == mySQLTypeBlob - || t == mySQLTypeVarString - || t == mySQLTypeString = (if isText then MySQLText . T.decodeUtf8 else MySQLBytes) <$> getLenEncBytes - - | t == mySQLTypeBit = MySQLBit <$> (getBits =<< getLenEncInt) +decodeTextField :: ColumnDef -> P.Parser MySQLValue +decodeTextField f + | t == MySQLTypeNull = pure MySQLNull + | t == MySQLTypeDecimal + || t == MySQLTypeNewDecimal = feedLenEncBytes t MySQLDecimal P.scientific' + | t == MySQLTypeTiny = if isUnsigned then feedLenEncBytes t MySQLInt8U P.uint + else feedLenEncBytes t MySQLInt8 P.int + | t == MySQLTypeShort = if isUnsigned then feedLenEncBytes t MySQLInt16U P.uint + else feedLenEncBytes t MySQLInt16 P.int + | t == MySQLTypeLong + || t == MySQLTypeInt24 = if isUnsigned then feedLenEncBytes t MySQLInt32U P.uint + else feedLenEncBytes t MySQLInt32 P.int + | t == MySQLTypeLongLong = if isUnsigned then feedLenEncBytes t MySQLInt64U P.uint + else feedLenEncBytes t MySQLInt64 P.int + | t == MySQLTypeFloat = feedLenEncBytes t MySQLFloat P.float' + | t == MySQLTypeDouble = feedLenEncBytes t MySQLDouble P.double' + | t == MySQLTypeYear = feedLenEncBytes t MySQLYear P.int + | t == MySQLTypeTimestamp + || t == MySQLTypeTimestamp2 = feedLenEncBytes t MySQLTimeStamp $ P.localTime + | t == MySQLTypeDateTime + || t == MySQLTypeDateTime2 = feedLenEncBytes t MySQLDateTime $ P.localTime + | t == MySQLTypeDate + || t == MySQLTypeNewDate = feedLenEncBytes t MySQLDate P.day + | t == MySQLTypeTime + || t == MySQLTypeTime2 = feedLenEncBytes t id $ do + sign <- P.peek + if sign == 45 -- '-' + then P.skipWord8 >> (MySQLTime 1 <$> P.timeOfDay) + else MySQLTime 0 <$> P.timeOfDay + + | t == MySQLTypeGeometry = MySQLGeometry <$> decodeLenEncBytes + | t == MySQLTypeVarChar + || t == MySQLTypeEnum + || t == MySQLTypeSet + || t == MySQLTypeTinyBlob + || t == MySQLTypeMediumBlob + || t == MySQLTypeLongBlob + || t == MySQLTypeBlob + || t == MySQLTypeVarString + || t == MySQLTypeString = (if isText then MySQLText . T.validate else MySQLBytes) <$> decodeLenEncBytes + + | t == MySQLTypeBit = MySQLBit <$> (decodeBits =<< decodeLenEncInt) | otherwise = fail $ "Database.MySQL.Protocol.MySQLValue: missing text decoder for " ++ show t where t = columnType f isUnsigned = flagUnsigned (columnFlags f) isText = columnCharSet f /= 63 - intLexer bs = fst <$> LexInt.readSigned LexInt.readDecimal bs - fracLexer bs = fst <$> LexFrac.readSigned LexFrac.readDecimal bs - dateParser bs = do - (yyyy, rest) <- LexInt.readDecimal bs - (mm, rest') <- LexInt.readDecimal (B.unsafeTail rest) - (dd, _) <- LexInt.readDecimal (B.unsafeTail rest') - return (fromGregorian yyyy mm dd) - - timeParser bs = do - (hh, rest) <- LexInt.readDecimal bs - (mm, rest') <- LexInt.readDecimal (B.unsafeTail rest) - (ss, _) <- LexFrac.readDecimal (B.unsafeTail rest') - return (TimeOfDay hh mm ss) - - -feedLenEncBytes :: FieldType -> (t -> b) -> (ByteString -> Maybe t) -> Get b -feedLenEncBytes typ con parser = do - bs <- getLenEncBytes - case parser bs of - Just v -> return (con v) - Nothing -> fail $ "Database.MySQL.Protocol.MySQLValue: parsing " ++ show typ ++ " failed, \ - \input: " ++ BC.unpack bs + +feedLenEncBytes :: FieldType -> (t -> b) -> P.Parser t -> P.Parser b {-# INLINE feedLenEncBytes #-} +feedLenEncBytes typ con p = do + bs <- decodeLenEncBytes + case P.parse' p bs of + Right v -> return (con v) + Left e -> fail $ "Database.MySQL.Protocol.MySQLValue: parsing " ++ show typ ++ " failed, " ++ show e -------------------------------------------------------------------------------- -- | Text protocol encoder -putTextField :: MySQLValue -> Put -putTextField (MySQLDecimal n) = putBuilder (formatScientificBuilder Fixed Nothing n) -putTextField (MySQLInt8U n) = putBuilder (Textual.integral n) -putTextField (MySQLInt8 n) = putBuilder (Textual.integral n) -putTextField (MySQLInt16U n) = putBuilder (Textual.integral n) -putTextField (MySQLInt16 n) = putBuilder (Textual.integral n) -putTextField (MySQLInt32U n) = putBuilder (Textual.integral n) -putTextField (MySQLInt32 n) = putBuilder (Textual.integral n) -putTextField (MySQLInt64U n) = putBuilder (Textual.integral n) -putTextField (MySQLInt64 n) = putBuilder (Textual.integral n) -putTextField (MySQLFloat x) = putBuilder (Textual.float x) -putTextField (MySQLDouble x) = putBuilder (Textual.double x) -putTextField (MySQLYear n) = putBuilder (Textual.integral n) -putTextField (MySQLDateTime dt) = putInQuotes $ - putByteString (BC.pack (formatTime defaultTimeLocale "%F %T%Q" dt)) -putTextField (MySQLTimeStamp dt) = putInQuotes $ - putByteString (BC.pack (formatTime defaultTimeLocale "%F %T%Q" dt)) -putTextField (MySQLDate d) = putInQuotes $ - putByteString (BC.pack (formatTime defaultTimeLocale "%F" d)) -putTextField (MySQLTime sign t) = putInQuotes $ do - when (sign == 1) (putCharUtf8 '-') - putByteString (BC.pack (formatTime defaultTimeLocale "%T%Q" t)) +encodeTextField :: MySQLValue -> B.Builder () +encodeTextField (MySQLDecimal n) = B.scientific n +encodeTextField (MySQLInt8U n) = B.int n +encodeTextField (MySQLInt8 n) = B.int n +encodeTextField (MySQLInt16U n) = B.int n +encodeTextField (MySQLInt16 n) = B.int n +encodeTextField (MySQLInt32U n) = B.int n +encodeTextField (MySQLInt32 n) = B.int n +encodeTextField (MySQLInt64U n) = B.int n +encodeTextField (MySQLInt64 n) = B.int n +encodeTextField (MySQLFloat x) = B.float x +encodeTextField (MySQLDouble x) = B.double x +encodeTextField (MySQLYear n) = B.int n +encodeTextField (MySQLDateTime dt) = B.squotes $ B.localTime dt +encodeTextField (MySQLTimeStamp dt) = B.squotes $ B.localTime dt +encodeTextField (MySQLDate d) = B.squotes $ B.day d +encodeTextField (MySQLTime sign t) = B.squotes $ do + when (sign == 1) (B.char8 '-') + B.string8 (formatTime defaultTimeLocale "%T%Q" t) -- this works even for hour > 24 -putTextField (MySQLGeometry bs) = putInQuotes $ putByteString . escapeBytes $ bs -putTextField (MySQLBytes bs) = putInQuotes $ putByteString . escapeBytes $ bs -putTextField (MySQLText t) = putInQuotes $ - putByteString . T.encodeUtf8 . escapeText $ t -putTextField (MySQLBit b) = do putBuilder "b\'" - putBuilder . execPut $ putTextBits b - putCharUtf8 '\'' +encodeTextField (MySQLGeometry bs) = B.squotes $ escapeBytes $ bs +encodeTextField (MySQLBytes bs) = B.squotes $ escapeBytes $ bs +encodeTextField (MySQLText t) = B.squotes $ escapeText $ t +encodeTextField (MySQLBit b) = do + "b\'" + encodeTextBits b + B.char8 '\'' where - putTextBits :: Word64 -> Put - putTextBits word = forM_ [63,62..0] $ \ pos -> - if word `testBit` pos then putCharUtf8 '1' else putCharUtf8 '0' - {-# INLINE putTextBits #-} - -putTextField MySQLNull = putBuilder "NULL" + encodeTextBits :: Word64 -> B.Builder () + encodeTextBits word = forM_ [63,62..0] $ \ pos -> + if word `testBit` pos then B.char8 '1' else B.char8 '0' + {-# INLINE encodeTextBits #-} -putInQuotes :: Put -> Put -putInQuotes p = putCharUtf8 '\'' >> p >> putCharUtf8 '\'' -{-# INLINE putInQuotes #-} +encodeTextField MySQLNull = "NULL" -------------------------------------------------------------------------------- -- | Text row decoder -getTextRow :: [ColumnDef] -> Get [MySQLValue] -getTextRow fs = forM fs $ \ f -> do - p <- peek - if p == 0xFB - then skipN 1 >> return MySQLNull - else getTextField f -{-# INLINE getTextRow #-} -getTextRowVector :: V.Vector ColumnDef -> Get (V.Vector MySQLValue) -getTextRowVector fs = V.forM fs $ \ f -> do - p <- peek +decodeTextRow :: V.Vector ColumnDef -> P.Parser (V.Vector MySQLValue) +decodeTextRow fs = (`V.traverseVec` fs) $ \ f -> do + p <- P.peek if p == 0xFB - then skipN 1 >> return MySQLNull - else getTextField f -{-# INLINE getTextRowVector #-} + then P.skipWord8 >> return MySQLNull + else decodeTextField f +{-# INLINE decodeTextRow #-} -------------------------------------------------------------------------------- -- | Binary protocol decoder -getBinaryField :: ColumnDef -> Get MySQLValue -getBinaryField f - | t == mySQLTypeNull = pure MySQLNull - | t == mySQLTypeDecimal - || t == mySQLTypeNewDecimal = feedLenEncBytes t MySQLDecimal fracLexer - | t == mySQLTypeTiny = if isUnsigned then MySQLInt8U <$> getWord8 - else MySQLInt8 <$> getInt8 - | t == mySQLTypeShort = if isUnsigned then MySQLInt16U <$> getWord16le - else MySQLInt16 <$> getInt16le - | t == mySQLTypeLong - || t == mySQLTypeInt24 = if isUnsigned then MySQLInt32U <$> getWord32le - else MySQLInt32 <$> getInt32le - | t == mySQLTypeYear = MySQLYear . fromIntegral <$> getWord16le - | t == mySQLTypeLongLong = if isUnsigned then MySQLInt64U <$> getWord64le - else MySQLInt64 <$> getInt64le - | t == mySQLTypeFloat = MySQLFloat <$> getFloatle - | t == mySQLTypeDouble = MySQLDouble <$> getDoublele - | t == mySQLTypeTimestamp - || t == mySQLTypeTimestamp2 = do - n <- getLenEncInt +decodeBinaryField :: ColumnDef -> P.Parser MySQLValue +decodeBinaryField f + | t == MySQLTypeNull = pure MySQLNull + | t == MySQLTypeDecimal + || t == MySQLTypeNewDecimal = feedLenEncBytes t MySQLDecimal P.scientific' + | t == MySQLTypeTiny = if isUnsigned then MySQLInt8U <$> P.decodePrim + else MySQLInt8 <$> P.decodePrim + | t == MySQLTypeShort = if isUnsigned then MySQLInt16U <$> P.decodePrimLE + else MySQLInt16 <$> P.decodePrimLE + | t == MySQLTypeLong + || t == MySQLTypeInt24 = if isUnsigned then MySQLInt32U <$> P.decodePrimLE + else MySQLInt32 <$> P.decodePrimLE + | t == MySQLTypeYear = MySQLYear <$> P.decodePrimLE + | t == MySQLTypeLongLong = if isUnsigned then MySQLInt64U <$> P.decodePrimLE + else MySQLInt64 <$> P.decodePrimLE + | t == MySQLTypeFloat = MySQLFloat <$> P.decodePrimLE + | t == MySQLTypeDouble = MySQLDouble <$> P.decodePrimLE + | t == MySQLTypeTimestamp + || t == MySQLTypeTimestamp2 = do + n <- decodeLenEncInt case n of 0 -> pure $ MySQLTimeStamp (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0)) 4 -> do - d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8' + d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 pure $ MySQLTimeStamp (LocalTime d (TimeOfDay 0 0 0)) 7 -> do - d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8' - td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond4 + d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 + td <- TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond4 pure $ MySQLTimeStamp (LocalTime d td) 11 -> do - d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8' - td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond8 + d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 + td <- TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond8 pure $ MySQLTimeStamp (LocalTime d td) _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong TIMESTAMP length" - | t == mySQLTypeDateTime - || t == mySQLTypeDateTime2 = do - n <- getLenEncInt + | t == MySQLTypeDateTime + || t == MySQLTypeDateTime2 = do + n <- decodeLenEncInt case n of 0 -> pure $ MySQLDateTime (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0)) 4 -> do - d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8' + d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 pure $ MySQLDateTime (LocalTime d (TimeOfDay 0 0 0)) 7 -> do - d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8' - td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond4 + d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 + td <- TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond4 pure $ MySQLDateTime (LocalTime d td) 11 -> do - d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8' - td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond8 + d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 + td <- TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond8 pure $ MySQLDateTime (LocalTime d td) _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATETIME length" - | t == mySQLTypeDate - || t == mySQLTypeNewDate = do - n <- getLenEncInt + | t == MySQLTypeDate + || t == MySQLTypeNewDate = do + n <- decodeLenEncInt case n of 0 -> pure $ MySQLDate (fromGregorian 0 0 0) - 4 -> MySQLDate <$> (fromGregorian <$> getYear <*> getInt8' <*> getInt8') + 4 -> MySQLDate <$> (fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8) _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATE length" - | t == mySQLTypeTime - || t == mySQLTypeTime2 = do - n <- getLenEncInt + | t == MySQLTypeTime + || t == MySQLTypeTime2 = do + n <- decodeLenEncInt case n of 0 -> pure $ MySQLTime 0 (TimeOfDay 0 0 0) 8 -> do - sign <- getWord8 -- is_negative(1 if minus, 0 for plus) - d <- fromIntegral <$> getWord32le - h <- getInt8' - MySQLTime sign <$> (TimeOfDay (d*24 + h) <$> getInt8' <*> getSecond4) + sign <- P.anyWord8 -- is_negative(1 if minus, 0 for plus) + d <- fromIntegral <$> P.decodePrimLE @Word32 + h <- decodeInt8 + MySQLTime sign <$> (TimeOfDay (d*24 + h) <$> decodeInt8 <*> decodeSecond4) 12 -> do - sign <- getWord8 -- is_negative(1 if minus, 0 for plus) - d <- fromIntegral <$> getWord32le - h <- getInt8' - MySQLTime sign <$> (TimeOfDay (d*24 + h) <$> getInt8' <*> getSecond8) + sign <- P.anyWord8 -- is_negative(1 if minus, 0 for plus) + d <- fromIntegral <$> P.decodePrimLE @Word32 + h <- decodeInt8 + MySQLTime sign <$> (TimeOfDay (d*24 + h) <$> decodeInt8 <*> decodeSecond8) _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong TIME length" - | t == mySQLTypeGeometry = MySQLGeometry <$> getLenEncBytes - | t == mySQLTypeVarChar - || t == mySQLTypeEnum - || t == mySQLTypeSet - || t == mySQLTypeTinyBlob - || t == mySQLTypeMediumBlob - || t == mySQLTypeLongBlob - || t == mySQLTypeBlob - || t == mySQLTypeVarString - || t == mySQLTypeString = if isText then MySQLText . T.decodeUtf8 <$> getLenEncBytes - else MySQLBytes <$> getLenEncBytes - | t == mySQLTypeBit = MySQLBit <$> (getBits =<< getLenEncInt) + | t == MySQLTypeGeometry = MySQLGeometry <$> decodeLenEncBytes + | t == MySQLTypeVarChar + || t == MySQLTypeEnum + || t == MySQLTypeSet + || t == MySQLTypeTinyBlob + || t == MySQLTypeMediumBlob + || t == MySQLTypeLongBlob + || t == MySQLTypeBlob + || t == MySQLTypeVarString + || t == MySQLTypeString = do + bs <- decodeLenEncBytes + if isText + then pure (MySQLText (T.validate bs)) + else pure (MySQLBytes bs) + | t == MySQLTypeBit = MySQLBit <$> (decodeBits =<< decodeLenEncInt) | otherwise = fail $ "Database.MySQL.Protocol.MySQLValue:\ \ missing binary decoder for " ++ show t where t = columnType f isUnsigned = flagUnsigned (columnFlags f) isText = columnCharSet f /= 63 - fracLexer bs = fst <$> LexFrac.readSigned LexFrac.readDecimal bs - getYear :: Get Integer - getYear = fromIntegral <$> getWord16le - getInt8' :: Get Int - getInt8' = fromIntegral <$> getWord8 - getSecond4 :: Get Pico - getSecond4 = realToFrac <$> getWord8 - getSecond8 :: Get Pico - getSecond8 = realToFrac <$> do - s <- getInt8' - ms <- fromIntegral <$> getWord32le :: Get Int + decodeYear :: P.Parser Integer + decodeYear = fromIntegral <$> P.decodePrimLE @Word16 + decodeInt8 :: P.Parser Int + decodeInt8 = fromIntegral <$> P.anyWord8 + decodeSecond4 :: P.Parser Pico + decodeSecond4 = realToFrac <$> P.anyWord8 + decodeSecond8 :: P.Parser Pico + decodeSecond8 = realToFrac <$> do + s <- decodeInt8 + (ms :: Int) <- fromIntegral <$> P.decodePrimLE @Word32 pure $! (realToFrac s + realToFrac ms / 1000000 :: Pico) --- | Get a bit sequence as a Word64 +-- | decode a bit sequence as a Word64 -- --- Since 'Word64' has a @Bits@ instance, it's easier to deal with in haskell. +-- Since 'Word64' has a @Bits@ instance, it's easier to deal with in Haskell. -- -getBits :: Int -> Get Word64 -getBits bytes = - if | bytes == 0 || bytes == 1 -> fromIntegral <$> getWord8 - | 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 +decodeBits :: Int -> P.Parser Word64 +decodeBits bytes = + if | bytes == 0 || bytes == 1 -> fromIntegral <$> P.anyWord8 + | bytes == 2 -> fromIntegral <$> P.decodePrimBE @Word16 + | bytes == 3 -> fromIntegral <$> decodeWord24BE + | bytes == 4 -> fromIntegral <$> P.decodePrimBE @Word32 + | bytes == 5 -> fromIntegral <$> decodeWord40BE + | bytes == 6 -> fromIntegral <$> decodeWord48BE + | bytes == 7 -> fromIntegral <$> decodeWord56BE + | bytes == 8 -> fromIntegral <$> P.decodePrimBE @Word64 | otherwise -> fail $ "Database.MySQL.Protocol.MySQLValue: \ \wrong bit length size: " ++ show bytes -{-# INLINE getBits #-} +{-# INLINE decodeBits #-} -------------------------------------------------------------------------------- -- | Binary protocol encoder -putBinaryField :: MySQLValue -> Put -putBinaryField (MySQLDecimal n) = putLenEncBytes . L.toStrict . BB.toLazyByteString $ - formatScientificBuilder Fixed Nothing n -putBinaryField (MySQLInt8U n) = putWord8 n -putBinaryField (MySQLInt8 n) = putWord8 (fromIntegral n) -putBinaryField (MySQLInt16U n) = putWord16le n -putBinaryField (MySQLInt16 n) = putInt16le n -putBinaryField (MySQLInt32U n) = putWord32le n -putBinaryField (MySQLInt32 n) = putInt32le n -putBinaryField (MySQLInt64U n) = putWord64le n -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 +encodeBinaryField :: MySQLValue -> B.Builder () +encodeBinaryField (MySQLDecimal n) = encodeLenEncBytes $ B.build (B.scientific n) +encodeBinaryField (MySQLInt8U n) = B.word8 n +encodeBinaryField (MySQLInt8 n) = B.word8 (fromIntegral n) +encodeBinaryField (MySQLInt16U n) = B.encodePrimLE n +encodeBinaryField (MySQLInt16 n) = B.encodePrimLE n +encodeBinaryField (MySQLInt32U n) = B.encodePrimLE n +encodeBinaryField (MySQLInt32 n) = B.encodePrimLE n +encodeBinaryField (MySQLInt64U n) = B.encodePrimLE n +encodeBinaryField (MySQLInt64 n) = B.encodePrimLE n +encodeBinaryField (MySQLFloat x) = B.encodePrimLE x +encodeBinaryField (MySQLDouble x) = B.encodePrimLE x +encodeBinaryField (MySQLYear n) = encodeLenEncBytes $ B.build (B.int n) + -- this's really weird, it's not documented anywhere -- we must encode year into string in binary mode! -putBinaryField (MySQLTimeStamp (LocalTime date time)) = do putWord8 11 -- always put full - putBinaryDay date - putBinaryTime' time -putBinaryField (MySQLDateTime (LocalTime date time)) = do putWord8 11 -- always put full - putBinaryDay date - putBinaryTime' time -putBinaryField (MySQLDate d) = do putWord8 4 - putBinaryDay d -putBinaryField (MySQLTime sign t) = do putWord8 12 -- always put full - putWord8 sign - putBinaryTime t -putBinaryField (MySQLGeometry bs) = putLenEncBytes bs -putBinaryField (MySQLBytes bs) = putLenEncBytes bs -putBinaryField (MySQLBit word) = do putWord8 8 -- always put full - putWord64be word -putBinaryField (MySQLText t) = putLenEncBytes (T.encodeUtf8 t) -putBinaryField MySQLNull = return () - -putBinaryDay :: Day -> Put -putBinaryDay d = do let (yyyy, mm, dd) = toGregorian d - putWord16le (fromIntegral yyyy) - putWord8 (fromIntegral mm) - putWord8 (fromIntegral dd) -{-# INLINE putBinaryDay #-} - -putBinaryTime' :: TimeOfDay -> Put -putBinaryTime' (TimeOfDay hh mm ss) = do let s = floor ss - ms = floor $ (ss - realToFrac s) * 1000000 - putWord8 (fromIntegral hh) - putWord8 (fromIntegral mm) - putWord8 s - putWord32le ms -{-# INLINE putBinaryTime' #-} - -putBinaryTime :: TimeOfDay -> Put -putBinaryTime (TimeOfDay hh mm ss) = do let s = floor ss - ms = floor $ (ss - realToFrac s) * 1000000 - (d, h) = hh `quotRem` 24 -- hour may exceed 24 here - putWord32le (fromIntegral d) - putWord8 (fromIntegral h) - putWord8 (fromIntegral mm) - putWord8 s - putWord32le ms -{-# INLINE putBinaryTime #-} +encodeBinaryField (MySQLTimeStamp (LocalTime date time)) = do B.word8 11 -- always encode full + encodeBinaryDay date + encodeBinaryTime' time +encodeBinaryField (MySQLDateTime (LocalTime date time)) = do B.word8 11 -- always encode full + encodeBinaryDay date + encodeBinaryTime' time +encodeBinaryField (MySQLDate d) = do B.word8 4 + encodeBinaryDay d +encodeBinaryField (MySQLTime sign t) = do B.word8 12 -- always encode full + B.word8 sign + encodeBinaryTime t +encodeBinaryField (MySQLGeometry bs) = encodeLenEncBytes bs +encodeBinaryField (MySQLBytes bs) = encodeLenEncBytes bs +encodeBinaryField (MySQLBit word) = do B.word8 8 -- always encode full + B.encodePrimBE word +encodeBinaryField (MySQLText t) = encodeLenEncBytes (T.getUTF8Bytes t) +encodeBinaryField MySQLNull = return () + +encodeBinaryDay :: Day -> B.Builder () +encodeBinaryDay d = do + let (yyyy, mm, dd) = toGregorian d + B.encodePrimLE @Word16 (fromIntegral yyyy) + B.word8 (fromIntegral mm) + B.word8 (fromIntegral dd) +{-# INLINE encodeBinaryDay #-} + +encodeBinaryTime' :: TimeOfDay -> B.Builder () +encodeBinaryTime' (TimeOfDay hh mm ss) = do + let s = floor ss + ms = floor $ (ss - realToFrac s) * 1000000 + B.word8 (fromIntegral hh) + B.word8 (fromIntegral mm) + B.word8 s + B.encodePrimLE @Word32 ms +{-# INLINE encodeBinaryTime' #-} + +encodeBinaryTime :: TimeOfDay -> B.Builder () +encodeBinaryTime (TimeOfDay hh mm ss) = do + let s = floor ss + ms = floor $ (ss - realToFrac s) * 1000000 + (d, h) = hh `quotRem` 24 -- hour may exceed 24 here + B.encodePrimLE @Word32 (fromIntegral d) + B.word8 (fromIntegral h) + B.word8 (fromIntegral mm) + B.word8 s + B.encodePrimLE @Word32 ms +{-# INLINE encodeBinaryTime #-} -------------------------------------------------------------------------------- -- | Binary row decoder -- -- MySQL use a special null bitmap without offset = 2 here. --- -getBinaryRow :: [ColumnDef] -> Int -> Get [MySQLValue] -getBinaryRow fields flen = do - skipN 1 -- 0x00 - let maplen = (flen + 7 + 2) `shiftR` 3 - nullmap <- BitMap <$> getByteString maplen - go fields nullmap 0 - where - go :: [ColumnDef] -> BitMap -> Int -> Get [MySQLValue] - go [] _ _ = pure [] - go (f:fs) nullmap pos = do - r <- if isColumnNull nullmap pos - then return MySQLNull - else getBinaryField f - let pos' = pos + 1 - rest <- pos' `seq` go fs nullmap pos' - return (r `seq` (r : rest)) -{-# INLINE getBinaryRow #-} - -getBinaryRowVector :: V.Vector ColumnDef -> Int -> Get (V.Vector MySQLValue) -getBinaryRowVector fields flen = do - skipN 1 -- 0x00 + +decodeBinaryRow :: V.Vector ColumnDef -> Int -> P.Parser (V.Vector MySQLValue) +decodeBinaryRow fields flen = do + P.skipWord8 -- 0x00 let maplen = (flen + 7 + 2) `shiftR` 3 - nullmap <- BitMap <$> getByteString maplen - (`V.imapM` fields) $ \ pos f -> - if isColumnNull nullmap pos then return MySQLNull else getBinaryField f -{-# INLINE getBinaryRowVector #-} + nullmap <- BitMap <$> P.take maplen + (`V.traverseWithIndex` fields) $ \ pos f -> + if isColumnNull nullmap pos then return MySQLNull else decodeBinaryField f +{-# INLINE decodeBinaryRow #-} -------------------------------------------------------------------------------- -- | Use 'ByteString' to present a bitmap. @@ -522,36 +465,37 @@ getBinaryRowVector fields flen = do -- -- We don't use 'Int64' here because there maybe more than 64 columns. -- -newtype BitMap = BitMap { fromBitMap :: ByteString } deriving (Eq, Show) +newtype BitMap = BitMap { fromBitMap :: V.Bytes } deriving (Eq, Show) -- | Test if a column is set(binlog protocol). -- -- The number counts from left to right. -- isColumnSet :: BitMap -> Int -> Bool +{-# INLINE isColumnSet #-} isColumnSet (BitMap bitmap) pos = let i = pos `unsafeShiftR` 3 j = pos .&. 7 - in (bitmap `B.unsafeIndex` i) `testBit` j -{-# INLINE isColumnSet #-} + in (bitmap `V.unsafeIndex` i) `testBit` j -- | Test if a column is null(binary protocol). -- -- The number counts from left to right. -- isColumnNull :: BitMap -> Int -> Bool +{-# INLINE isColumnNull #-} isColumnNull (BitMap nullmap) pos = let pos' = pos + 2 i = pos' `unsafeShiftR` 3 j = pos' .&. 7 - in (nullmap `B.unsafeIndex` i) `testBit` j -{-# INLINE isColumnNull #-} + in (nullmap `V.unsafeIndex` i) `testBit` j -- | Make a nullmap for params(binary protocol) without offset. -- makeNullMap :: [MySQLValue] -> BitMap -makeNullMap values = BitMap . B.pack $ go values 0x00 0 +{-# INLINE makeNullMap #-} +makeNullMap values = BitMap . V.pack $ go values 0x00 0 where go :: [MySQLValue] -> Word8 -> Int -> [Word8] go [] byte 8 = [byte] @@ -563,5 +507,5 @@ makeNullMap values = BitMap . B.pack $ go values 0x00 0 go (_ :vs) byte pos = let pos' = pos + 1 in pos' `seq` go vs byte pos' -------------------------------------------------------------------------------- --- TODO: add helpers to parse mySQLTypeGEOMETRY +-- TODO: add helpers to parse MySQLTypeGEOMETRY -- reference: https://github.com/felixge/node-mysql/blob/master/lib/protocol/Parser.js diff --git a/Database/MySQL/Protocol/Packet.hs b/Database/MySQL/Protocol/Packet.hs index fa5145a..f7049b1 100644 --- a/Database/MySQL/Protocol/Packet.hs +++ b/Database/MySQL/Protocol/Packet.hs @@ -77,7 +77,6 @@ decodeFromPacket :: P.Parser a -> Packet -> IO a decodeFromPacket g (Packet _ _ body) = unwrap "EPARSE" $ P.parse' g body {-# INLINE decodeFromPacket #-} - -- Encode a packet with a sequence number encodeToPacket :: Word8 -> B.Builder () -> Packet encodeToPacket seqN payload = @@ -108,39 +107,23 @@ decodeOK = OK <$ P.skip 1 <*> P.decodePrimLE @Word16 {-# INLINE decodeOK #-} -encodeOK :: OK -> B.Builder () -encodeOK (OK row lid stat wcnt) = do - B.word8 0x00 - encodeLenEncInt row - encodeLenEncInt lid - B.encodePrimLE @Word16 stat - B.encodePrimLE @Word16 wcnt -{-# INLINE encodeOK #-} - data ERR = ERR { errCode :: {-# UNPACK #-} !Word16 - , errState :: !V.Bytes - , errMsg :: !V.Bytes + , errState :: !T.Text + , errMsg :: !T.Text } deriving (Show, Eq, Ord, Generic) deriving anyclass T.Print decodeERR :: P.Parser ERR -decodeERR = ERR <$ P.skip 1 - <*> P.decodePrimLE @Word16 - <* P.skip 1 - <*> P.take 5 - <*> P.takeRemaining +decodeERR = do + _ <- P.skipWord8 + code <- P.decodePrimLE @Word16 + _ <- P.skipWord8 + st <- P.take 5 + msg <- P.takeRemaining + return (ERR code (T.validate st) (T.validate msg)) {-# INLINE decodeERR #-} -encodeERR :: ERR -> B.Builder () -encodeERR (ERR code stat msg) = do - B.word8 0xFF - B.encodePrimLE @Word16 code - B.word8 35 -- '#' - B.bytes stat - B.bytes msg -{-# INLINE encodeERR #-} - data EOF = EOF { eofWarningCnt :: {-# UNPACK #-} !Word16 , eofStatus :: {-# UNPACK #-} !Word16 @@ -153,13 +136,6 @@ decodeEOF = EOF <$ P.skip 1 <*> P.decodePrimLE @Word16 {-# INLINE decodeEOF #-} -encodeEOF :: EOF -> B.Builder () -encodeEOF (EOF wcnt stat) = do - B.word8 0xFE - B.encodePrimLE @Word16 wcnt - B.encodePrimLE @Word16 stat -{-# INLINE encodeEOF #-} - -------------------------------------------------------------------------------- -- Helpers diff --git a/Database/MySQL/Query.hs b/Database/MySQL/Query.hs index a389ff9..0570319 100644 --- a/Database/MySQL/Query.hs +++ b/Database/MySQL/Query.hs @@ -1,14 +1,14 @@ module Database.MySQL.Query where +import Control.Arrow (first) +import Database.MySQL.Protocol.MySQLValue import Data.String (IsString (..)) -import Control.Exception (throw, Exception) import Data.Typeable +import Z.Data.ASCII import qualified Z.Data.Builder as B import qualified Z.Data.Vector as V import qualified Z.Data.Text as T -import Control.Arrow (first) -import Database.MySQL.Protocol.MySQLValue -import Data.Binary.Put +import Z.IO.Exception -- | Query string type borrowed from @mysql-simple@. -- @@ -21,11 +21,11 @@ import Data.Binary.Put -- construct a query is to enable the @OverloadedStrings@ language -- extension and then simply write the query in double quotes. -- --- The underlying type is a 'L.ByteString', and literal Haskell strings +-- The underlying type is a 'V.Bytes', and literal Haskell strings -- that contain Unicode characters will be correctly transformed to -- UTF-8. -- -newtype Query = Query { fromQuery :: L.ByteString } deriving (Eq, Ord, Typeable) +newtype Query = Query { fromQuery :: V.Bytes } deriving (Eq, Ord, Typeable) instance Show Query where show = show . fromQuery @@ -34,16 +34,16 @@ instance Read Query where readsPrec i = fmap (first Query) . readsPrec i instance IsString Query where - fromString = Query . BB.toLazyByteString . BB.stringUtf8 + fromString = Query . fromString -- | A type to wrap a query parameter in to allow for single and multi-valued parameters. -- -- The behavior of 'Param' can be illustrated by following example: -- -- @ --- render $ One (MySQLText "hello") = hello --- render $ Many [MySQLText "hello", MySQLText "world"] = hello, world --- render $ Many [] = null +-- buildParam $ One (MySQLText "hello") = hello +-- buildParam $ Many [MySQLText "hello", MySQLText "world"] = hello, world +-- buildParam $ Many [] = null -- @ -- -- So you can now write a query like this: @ SELECT * FROM test WHERE _id IN (?, 888) @ @@ -54,27 +54,27 @@ data Param = One MySQLValue -- | A type that may be used as a single parameter to a SQL query. Inspired from @mysql-simple@. class QueryParam a where - render :: a -> Put + buildParam :: a -> B.Builder () -- ^ Prepare a value for substitution into a query string. instance QueryParam Param where - render (One x) = putTextField x - render (Many []) = putTextField MySQLNull - render (Many (x:[]))= putTextField x - render (Many (x:xs))= do putTextField x - mapM_ (\f -> putCharUtf8 ',' >> putTextField f) xs + {-# INLINE buildParam #-} + buildParam (One x) = encodeTextField x + buildParam (Many []) = "NULL" + buildParam (Many xs) = B.intercalateList (B.comma) encodeTextField xs instance QueryParam MySQLValue where - render = putTextField + {-# INLINE buildParam #-} + buildParam = encodeTextField -renderParams :: QueryParam p => Query -> [p] -> Query +renderParams :: HasCallStack => QueryParam p => Query -> [p] -> Query renderParams (Query qry) params = - let fragments = LC.split '?' qry - in Query . runPut $ merge fragments params + let fragments = V.split QUESTION qry + in Query . B.build $ merge fragments params where - merge [x] [] = putLazyByteString x - merge (x:xs) (y:ys) = putLazyByteString x >> render y >> merge xs ys - merge _ _ = throw WrongParamsCount + merge [x] [] = B.bytes x + merge (x:xs) (y:ys) = B.bytes x >> buildParam y >> merge xs ys + merge _ _ = throw (WrongParamsCount callStack) -data WrongParamsCount = WrongParamsCount deriving (Show, Typeable) +data WrongParamsCount = WrongParamsCount CallStack deriving Show instance Exception WrongParamsCount diff --git a/cbits/escape.c b/cbits/escape.c new file mode 100644 index 0000000..8f68ab6 --- /dev/null +++ b/cbits/escape.c @@ -0,0 +1,63 @@ +#include +#include + +/* reference: + + * Escape Sequence Character Represented by Sequence + * \0 An ASCII NUL (X'00') character + * \' A single quote (“'”) character + * \" A double quote (“"”) character + * \b A backspace character + * \n A newline (linefeed) character + * \r A carriage return character + * \t A tab character + * \Z ASCII 26 (Control+Z); see note following the table + * \\ A backslash (“\”) character + * \% A “%” character; see note following the table + * \_ A “_” character; see note following the table + +The @\%@ and @\_@ sequences are used to search for literal instances of @%@ and @_@ in pattern-matching contexts where they would otherwise be interpreted as wildcard characters, so we won't auto escape @%@ or @_@ here. +*/ + +static const int mysql_escape_char_table[256] = + { 2,1,1,1,1,1,1,1,2,2,2,1,1,2,1,1, + 1,1,1,1,1,1,1,1,1,1,2,1,1,1,1,1, + 1,1,2,1,1,1,1,2,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,2,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1}; + +HsInt escape_mysql_string(const unsigned char *src, HsInt srcoff, HsInt srclen, unsigned char *dest, HsInt desoff){ + const unsigned char *i = src + srcoff; + const unsigned char *srcend = i + srclen; + unsigned char *j = dest + desoff; + for (; i < srcend; i++){ + if (mysql_escape_char_table[*i] == 1) { + *j++ = *i; + } else { + switch (*i) { + case 0: *j++ = '\\'; *j++ = '0'; break; + case '\'': *j++ = '\\'; *j++ = '\''; break; + case '\"': *j++ = '\\'; *j++ = '\"'; break; + case '\b': *j++ = '\\'; *j++ = 'b'; break; + case '\n': *j++ = '\\'; *j++ = 'n'; break; + case '\r': *j++ = '\\'; *j++ = 'r'; break; + case '\t': *j++ = '\\'; *j++ = 't'; break; + case 26: *j++ = '\\'; *j++ = 'Z'; break; + default: + *j++ = '\\'; *j++ = '\\'; break; + } + } + } + return (HsInt)(j-dest); +} diff --git a/mysql-haskell-openssl/ChangeLog.md b/mysql-haskell-openssl/ChangeLog.md deleted file mode 100644 index c73e20e..0000000 --- a/mysql-haskell-openssl/ChangeLog.md +++ /dev/null @@ -1,10 +0,0 @@ -# Revision history for mysql-haskell-openssl - -## 0.8.0.0 -- 2016-11-09 - -* Add `ciCharset` field to support `utf8mb4` charset. -* Add `BitMap` field to `COM_STMT_EXECUTE`, and [#8](https://github.com/winterland1989/mysql-haskell/pull/8) by [alexbiehl](https://github.com/alexbiehl). - -## 0.7.0.0 -- 2016-11-09 - -* Split from mysql-haskell. diff --git a/mysql-haskell-openssl/Database/MySQL/OpenSSL.hs b/mysql-haskell-openssl/Database/MySQL/OpenSSL.hs deleted file mode 100644 index 82a7332..0000000 --- a/mysql-haskell-openssl/Database/MySQL/OpenSSL.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-| -Module : Database.MySQL.Connection -Description : Alternative TLS support for mysql-haskell via @HsOpenSSL@ package. -Copyright : (c) Winterland, 2016 -License : BSD -Maintainer : drkoster@qq.com -Stability : experimental -Portability : PORTABLE - -This module provides secure MySQL connection using 'HsOpenSSL' package. - --} - -module Database.MySQL.OpenSSL - ( connect - , connectDetail - , module Data.OpenSSLSetting - ) where - -import Control.Exception (bracketOnError, throwIO) -import Control.Monad -import Data.IORef (newIORef) -import Data.Connection as Conn -import qualified Data.Binary as Binary -import qualified Data.Binary.Put as Binary -import Database.MySQL.Connection hiding (connect, connectDetail) -import Database.MySQL.Protocol.Auth -import Database.MySQL.Protocol.Packet -import qualified OpenSSL as SSL -import qualified OpenSSL.X509 as X509 -import qualified OpenSSL.Session as Session -import qualified System.IO.Streams.OpenSSL as SSL -import qualified System.IO.Streams.TCP as TCP -import Data.OpenSSLSetting - --------------------------------------------------------------------------------- - --- | Provide a 'Session.SSLContext' and a subject name to establish a TLS connection. --- -connect :: ConnectInfo -> (Session.SSLContext, String) -> IO MySQLConn -connect c cp = fmap snd (connectDetail c cp) - -connectDetail :: ConnectInfo -> (Session.SSLContext, String) -> IO (Greeting, MySQLConn) -connectDetail (ConnectInfo host port db user pass charset) (ctx, subname) = - bracketOnError (connectWithBufferSize host port bUFSIZE) Conn.close $ \ conn -> do - let is = Conn.source conn - is' <- decodeInputStream is - p <- readPacket is' - greet <- decodeFromPacket p - if supportTLS (greetingCaps greet) - then SSL.withOpenSSL $ do - write conn (encodeToPacket 1 $ sslRequest charset) - let (sock, sockAddr) = Conn.connExtraInfo conn - bracketOnError (Session.connection ctx sock) - (\ ssl -> do - Session.shutdown ssl Session.Unidirectional - Conn.close conn - ) $ \ ssl -> do - Session.connect ssl - trusted <- Session.getVerifyResult ssl - cert <- Session.getPeerCertificate ssl - subnames <- maybe (return []) (`X509.getSubjectName` False) cert - let cnname = lookup "CN" subnames - verified = maybe False (== subname) cnname - unless (trusted && verified) (throwIO $ Session.ProtocolError "fail to verify certificate") - sconn <- SSL.sslToConnection (ssl, sockAddr) - let sis = Conn.source sconn - auth = mkAuth db user pass charset greet - write sconn (encodeToPacket 2 auth) - sis' <- decodeInputStream sis - q <- readPacket sis' - if isOK q - then do - consumed <- newIORef True - let mconn = MySQLConn sis' (write sconn) (Conn.close sconn) consumed - return (greet, mconn) - else Conn.close sconn >> decodeFromPacket q >>= throwIO . ERRException - else error "Database.MySQL.OpenSSL: server doesn't support TLS connection" - where - connectWithBufferSize h p bs = TCP.connectSocket h p >>= TCP.socketToConnection bs - write c a = Conn.send c $ Binary.runPut . Binary.put $ a diff --git a/mysql-haskell-openssl/LICENSE b/mysql-haskell-openssl/LICENSE deleted file mode 100644 index 87d3e1b..0000000 --- a/mysql-haskell-openssl/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2016, winterland1989 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of winterland1989 nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/mysql-haskell-openssl/Setup.hs b/mysql-haskell-openssl/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/mysql-haskell-openssl/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/mysql-haskell-openssl/mysql-haskell-openssl.cabal b/mysql-haskell-openssl/mysql-haskell-openssl.cabal deleted file mode 100644 index 7cf1dbc..0000000 --- a/mysql-haskell-openssl/mysql-haskell-openssl.cabal +++ /dev/null @@ -1,36 +0,0 @@ -name: mysql-haskell-openssl -version: 0.8.3.1 -synopsis: TLS support for mysql-haskell package using openssl -description: TLS support for mysql-haskell package using openssl -license: BSD3 -license-file: LICENSE -author: winterland1989 -maintainer: winterland1989@gmail.com -copyright: (c) 2016 Winterland -category: Database -build-type: Simple -extra-source-files: ChangeLog.md -cabal-version: >=1.10 -homepage: https://github.com/winterland1989/mysql-haskell -bug-reports: https://github.com/winterland1989/mysql-haskell/issues - -source-repository head - type: git - location: git://github.com/winterland1989/mysql-haskell.git - -library - exposed-modules: Database.MySQL.OpenSSL - build-depends: base >= 4.7 && < 5 - , binary >= 0.8.3 - , tcp-streams >= 1.0 && < 1.1 - , tcp-streams-openssl >= 1.0 && < 1.1 - , wire-streams >= 0.1 - , mysql-haskell >= 0.8.3 && < 0.8.5 - , HsOpenSSL >=0.10.3 && <0.12 - - default-language: Haskell2010 - default-extensions: DeriveDataTypeable - , DeriveGeneric - , MultiWayIf - , OverloadedStrings - ghc-options: -Wall diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal index 0d67cfa..d44fbed 100644 --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -20,29 +20,28 @@ source-repository head library exposed-modules: Database.MySQL.Protocol.Packet + Database.MySQL.Protocol.Auth + Database.MySQL.Protocol.Command + Database.MySQL.Protocol.ColumnDef + Database.MySQL.Protocol.MySQLValue + Database.MySQL.Protocol.Escape + Database.MySQL.Connection - -- Database.MySQL.Base + Database.MySQL.Base --, Database.MySQL.TLS - --, Database.MySQL.Protocol.Auth - --, Database.MySQL.Protocol.Command - --, Database.MySQL.Protocol.ColumnDef - --, Database.MySQL.Protocol.Packet - --, Database.MySQL.Protocol.MySQLValue - --, Database.MySQL.Protocol.Escape --, Database.MySQL.BinLog --, Database.MySQL.BinLogProtocol.BinLogEvent --, Database.MySQL.BinLogProtocol.BinLogValue --, Database.MySQL.BinLogProtocol.BinLogMeta - --, Database.MySQL.Connection other-modules: -- Database.MySQL.Query build-depends: base >= 4.7 && < 5 , monad-loops == 0.4.* , time >= 1.5.0 , scientific == 0.3.* - , Z-Data >= 0.8.1 && < 0.9 - , Z-IO >= 0.8 && < 0.9 - , Z-Botan >= 0.2 && < 0.3 + , Z-Data >= 0.8.8 && < 0.9 + , Z-IO >= 0.8.1 && < 0.9 + , Z-Botan >= 0.4 && < 0.5 default-language: Haskell2010 @@ -54,6 +53,7 @@ library , OverloadedStrings , TypeApplications ghc-options: -Wall + c-sources: cbits/escape.c test-suite test type: exitcode-stdio-1.0 From 7d45bfd6594aee5b4030511e95cc134736774347 Mon Sep 17 00:00:00 2001 From: Dong Han Date: Fri, 2 Jul 2021 15:26:12 +0800 Subject: [PATCH 3/4] W.I.P --- Database/MySQL/BinLog.hs | 17 +- Database/MySQL/BinLogProtocol/BinLogEvent.hs | 249 +++++++++--------- Database/MySQL/BinLogProtocol/BinLogMeta.hs | 81 +++--- Database/MySQL/BinLogProtocol/BinLogValue.hs | 263 ++++++++++--------- Database/MySQL/Connection.hs | 92 +++++-- Database/MySQL/Protocol/Auth.hs | 75 ++++-- Database/MySQL/Protocol/ColumnDef.hs | 50 ++-- Database/MySQL/Protocol/MySQLValue.hs | 50 ++-- Database/MySQL/Protocol/Packet.hs | 13 +- benchmark/select/MySQLHaskell.hs | 33 +-- benchmark/select/MySQLHaskellPrepared.hs | 35 +-- benchmark/select/MySQLHaskellTLS.hs | 1 + benchmark/select/libmysql.cpp | 2 +- benchmark/select/mysql-haskell-bench.cabal | 72 +++-- mysql-haskell.cabal | 9 +- 15 files changed, 553 insertions(+), 489 deletions(-) diff --git a/Database/MySQL/BinLog.hs b/Database/MySQL/BinLog.hs index 4eac7d5..723bed4 100644 --- a/Database/MySQL/BinLog.hs +++ b/Database/MySQL/BinLog.hs @@ -29,14 +29,9 @@ module Database.MySQL.BinLog ) where import Control.Applicative -import Control.Exception (throwIO) +import Z.IO.Exception import Control.Monad -import Data.Binary.Put -import Data.ByteString (ByteString) -import Data.IORef (IORef, newIORef, - readIORef, - writeIORef) -import Data.Text.Encoding (encodeUtf8) +import Data.IORef import Data.Word import Database.MySQL.Base import Database.MySQL.BinLogProtocol.BinLogEvent @@ -44,15 +39,13 @@ import Database.MySQL.BinLogProtocol.BinLogMeta import Database.MySQL.BinLogProtocol.BinLogValue import Database.MySQL.Connection import GHC.Generics (Generic) -import System.IO.Streams (InputStream) -import qualified System.IO.Streams as Stream type SlaveID = Word32 -- | binlog filename and position to start listening. -- data BinLogTracker = BinLogTracker - { btFileName :: {-# UNPACK #-} !ByteString + { btFileName :: {-# UNPACK #-} !V.Bytes , btNextPos :: {-# UNPACK #-} !Word32 } deriving (Show, Eq, Generic) @@ -70,7 +63,7 @@ dumpBinLog :: MySQLConn -- ^ connection to be listened -> BinLogTracker -- ^ binlog position -> Bool -- ^ if master support semi-ack, do we want to enable it? -- if master doesn't support, this parameter will be ignored. - -> IO (FormatDescription, IORef ByteString, InputStream BinLogPacket) + -> IO (FormatDescription, IORef ByteString, Source BinLogPacket) -- ^ 'FormatDescription', 'IORef' contains current binlog filename, 'BinLogPacket' stream. dumpBinLog conn@(MySQLConn is wp _ consumed) sid (BinLogTracker initfn initpos) wantAck = do guardUnconsumed conn @@ -90,7 +83,7 @@ dumpBinLog conn@(MySQLConn is wp _ consumed) sid (BinLogTracker initfn initpos) replyAck needAck p fref wp fmt <- getFromBinLogPacket getFormatDescription p - es <- Stream.makeInputStream $ do + es <- sourceFromIO $ do q <- readBinLogPacket checksum needAck is case q of Nothing -> writeIORef consumed True >> return Nothing diff --git a/Database/MySQL/BinLogProtocol/BinLogEvent.hs b/Database/MySQL/BinLogProtocol/BinLogEvent.hs index 6ba6d5b..24f1604 100644 --- a/Database/MySQL/BinLogProtocol/BinLogEvent.hs +++ b/Database/MySQL/BinLogProtocol/BinLogEvent.hs @@ -14,25 +14,23 @@ Binlog event type module Database.MySQL.BinLogProtocol.BinLogEvent where -import Control.Applicative import Control.Monad import Control.Monad.Loops (untilM) -import Data.Binary -import Data.Binary.Parser import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Unsafe as B +import Data.Word import Database.MySQL.BinLogProtocol.BinLogMeta import Database.MySQL.BinLogProtocol.BinLogValue import Database.MySQL.Protocol.Packet import Database.MySQL.Protocol.MySQLValue import Database.MySQL.Protocol.ColumnDef - -import Control.Exception (throwIO) import Database.MySQL.Query import GHC.Generics (Generic) +import qualified Z.Data.Parser as P +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Extra as V +import Z.IO.Exception -------------------------------------------------------------------------------- -- | binlog tyoe @@ -77,72 +75,66 @@ data BinLogEventType deriving (Show, Eq, Enum) data BinLogPacket = BinLogPacket - { blTimestamp :: !Word32 - , blEventType :: !BinLogEventType - , blServerId :: !Word32 - , blEventSize :: !Word32 - , blLogPos :: !Word64 -- ^ for future GTID compatibility - , blFlags :: !Word16 - , blBody :: !L.ByteString + { blTimestamp :: {-# UNPACK #-} !Word32 + , blEventType :: {-# UNPACK #-} !BinLogEventType + , blServerId :: {-# UNPACK #-} !Word32 + , blEventSize :: {-# UNPACK #-} !Word32 + , blLogPos :: {-# UNPACK #-} !Word64 -- ^ for future GTID compatibility + , blFlags :: {-# UNPACK #-} !Word16 + , blBody :: {-# UNPACK #-} !V.Bytes , blSemiAck :: !Bool } deriving (Show, Eq) -putSemiAckResp :: Word32 -> ByteString -> Put -putSemiAckResp pos fn = put pos >> put fn +encodeSemiAckResp :: Word32 -> V.Bytes -> B.Builder () +encodeSemiAckResp pos fn = B.encodePrim pos >> B.bytes fn -getBinLogPacket :: Bool -> Bool -> Get BinLogPacket -getBinLogPacket checksum semi = do - _ <- getWord8 -- OK byte +decodeBinLogPacket :: Bool -> Bool -> P.Parser BinLogPacket +decodeBinLogPacket checksum semi = do + _ <- P.anyWord8 -- OK byte ack <- if semi - then getWord8 >> (== 0x01) <$> getWord8 + then P.anyWord8 >> (== 0x01) <$> P.anyWord8 else return False - ts <- getWord32le - typ <- toEnum . fromIntegral <$> getWord8 - sid <- getWord32le - size <- getWord32le - pos <- getWord32le - flgs <- getWord16le - body <- getLazyByteString (fromIntegral size - if checksum then 23 else 19) + ts <- P.decodePrimLE @Word32 + typ <- toEnum . fromIntegral <$> P.anyWord8 + sid <- P.decodePrimLE @Word32 + size <- P.decodePrimLE @Word32 + pos <- P.decodePrimLE @Word32 + flgs <- P.decodePrimLE @Word16 + body <- P.take (fromIntegral size - if checksum then 23 else 19) return (BinLogPacket ts typ sid size (fromIntegral pos) flgs body ack) -getFromBinLogPacket :: Get a -> BinLogPacket -> IO a -getFromBinLogPacket g (BinLogPacket _ _ _ _ _ _ body _ ) = - case parseDetailLazy g body of - Left (buf, offset, errmsg) -> throwIO (DecodePacketFailed buf offset errmsg) - Right (_, _, r ) -> return r +decodeFromBinLogPacket :: HasCallStack => P.Parser a -> BinLogPacket -> IO a +decodeFromBinLogPacket g (BinLogPacket _ _ _ _ _ _ body _ ) = unwrap "EPARSE" $ P.parse' g body -getFromBinLogPacket' :: (BinLogEventType -> Get a) -> BinLogPacket -> IO a -getFromBinLogPacket' g (BinLogPacket _ typ _ _ _ _ body _ ) = - case parseDetailLazy (g typ) body of - Left (buf, offset, errmsg) -> throwIO (DecodePacketFailed buf offset errmsg) - Right (_, _, r ) -> return r +decodeFromBinLogPacket' :: HasCallStack => (BinLogEventType -> P.Parser a) -> BinLogPacket -> IO a +decodeFromBinLogPacket' g (BinLogPacket _ typ _ _ _ _ body _ ) = unwrap "EPARSE" $ P.parse' (g typ) body -------------------------------------------------------------------------------- data FormatDescription = FormatDescription { fdVersion :: !Word16 - , fdMySQLVersion :: !ByteString + , fdMySQLVersion :: !V.Bytes , fdCreateTime :: !Word32 -- , eventHeaderLen :: !Word8 -- const 19 - , fdEventHeaderLenVector :: !ByteString -- ^ a array indexed by Binlog Event Type - 1 + , fdEventHeaderLenVector :: !V.Bytes -- ^ a array indexed by Binlog Event Type - 1 -- to extract the length of the event specific header. } deriving (Show, Eq, Generic) -getFormatDescription :: Get FormatDescription -getFormatDescription = FormatDescription <$> getWord16le - <*> getByteString 50 - <*> getWord32le - <* getWord8 - <*> (L.toStrict <$> getRemainingLazyByteString) +decodeFormatDescription :: P.Parser FormatDescription +decodeFormatDescription = FormatDescription <$> P.decodePrimLE @Word16 + <*> P.take 50 + <*> P.decodePrimLE @Word32 + <* P.anyWord8 + <*> P.takeRemaining eventHeaderLen :: FormatDescription -> BinLogEventType -> Word8 -eventHeaderLen fd typ = B.unsafeIndex (fdEventHeaderLenVector fd) (fromEnum typ - 1) +eventHeaderLen fd typ = V.unsafeIndex (fdEventHeaderLenVector fd) (fromEnum typ - 1) data RotateEvent = RotateEvent - { rPos :: !Word64, rFileName :: !ByteString } deriving (Show, Eq) + { rPos :: !Word64, rFileName :: !V.Bytes } deriving (Show, Eq) -getRotateEvent :: Get RotateEvent -getRotateEvent = RotateEvent <$> getWord64le <*> getRemainingByteString +decodeRotateEvent :: P.Parser RotateEvent +decodeRotateEvent = RotateEvent <$> P.decodePrimLE <*> P.takeRemaining -- | This's query parser for statement based binlog's query event, it's actually -- not used in row based binlog. @@ -151,65 +143,64 @@ data QueryEvent = QueryEvent { qSlaveProxyId :: !Word32 , qExecTime :: !Word32 , qErrCode :: !Word16 - , qStatusVars :: !ByteString - , qSchemaName :: !ByteString + , qStatusVars :: !V.Bytes + , qSchemaName :: !V.Bytes , qQuery :: !Query } deriving (Show, Eq, Generic) -getQueryEvent :: Get QueryEvent -getQueryEvent = do - pid <- getWord32le - tim <- getWord32le - slen <- getWord8 - ecode <- getWord16le - vlen <- getWord16le - svar <- getByteString (fromIntegral vlen) - schema <- getByteString (fromIntegral slen) - _ <- getWord8 - qry <- getRemainingLazyByteString +decodeQueryEvent :: P.Parser QueryEvent +decodeQueryEvent = do + pid <- P.decodePrimLE @Word32 + tim <- P.decodePrimLE @Word32 + slen <- P.anyWord8 + ecode <- P.decodePrimLE @Word16 + vlen <- P.decodePrimLE @Word16 + svar <- P.take (fromIntegral vlen) + schema <- P.take (fromIntegral slen) + _ <- P.anyWord8 + qry <- P.takeRemaining return (QueryEvent pid tim ecode svar schema (Query qry)) -- | This's the query event in row based binlog. -- data QueryEvent' = QueryEvent' { qQuery' :: !Query } deriving (Show, Eq) -getQueryEvent' :: Get QueryEvent' -getQueryEvent' = do - _ <- getWord8 - QueryEvent' . Query <$> getRemainingLazyByteString +decodeQueryEvent' :: P.Parser QueryEvent' +decodeQueryEvent' = do + _ <- P.anyWord8 + QueryEvent' . Query <$> P.takeRemaining data TableMapEvent = TableMapEvent { tmTableId :: !Word64 , tmFlags :: !Word16 - , tmSchemaName :: !ByteString - , tmTableName :: !ByteString + , tmSchemaName :: !V.Bytes + , tmTableName :: !V.Bytes , tmColumnCnt :: !Int - , tmColumnType :: ![FieldType] - , tmColumnMeta :: ![BinLogMeta] - , tmNullMap :: !ByteString + , tmColumnType :: !(V.PrimVector FieldType) + , tmColumnMeta :: !(V.Vector BinLogMeta) + , tmNullMap :: !V.Bytes } deriving (Show, Eq, Generic) -getTableMapEvent :: FormatDescription -> Get TableMapEvent -getTableMapEvent fd = do +decodeTableMapEvent :: FormatDescription -> P.Parser TableMapEvent +decodeTableMapEvent fd = do let hlen = eventHeaderLen fd BINLOG_TABLE_MAP_EVENT - tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le - flgs <- getWord16le - slen <- getWord8 - schema <- getByteString (fromIntegral slen) - _ <- getWord8 -- 0x00 - tlen <- getWord8 - table <- getByteString (fromIntegral tlen) - _ <- getWord8 -- 0x00 - cc <- getLenEncInt - colTypBS <- getByteString cc - let typs = map FieldType (B.unpack colTypBS) - colMetaBS <- getLenEncBytes - - metas <- case runGetOrFail (forM typs getBinLogMeta) (L.fromStrict colMetaBS) of - Left (_, _, errmsg) -> fail errmsg - Right (_, _, r) -> return r - - nullmap <- getByteString ((cc + 7) `div` 8) + tid <- if hlen == 6 then fromIntegral <$> P.decodePrimLE @Word32 else decodeWord48LE + flgs <- P.decodePrimLE @Word16 + slen <- P.anyWord8 + schema <- P.take (fromIntegral slen) + _ <- P.anyWord8 -- 0x00 + tlen <- P.anyWord8 + table <- P.take (fromIntegral tlen) + _ <- P.anyWord8 -- 0x00 + cc <- decodeLenEncInt + typs <- P.take cc + colMetaBS <- decodeLenEncBytes + + metas <- case P.parse' (V.traverseVec decodeBinLogMeta typs) colMetaBS of + Left errmsg -> P.fail' (T.concat errmsg) + Right r -> return r + + nullmap <- P.take ((cc + 7) `div` 8) return (TableMapEvent tid flgs schema table cc typs metas nullmap) data DeleteRowsEvent = DeleteRowsEvent @@ -221,18 +212,18 @@ data DeleteRowsEvent = DeleteRowsEvent , deleteRowData :: ![[BinLogValue]] } deriving (Show, Eq, Generic) -getDeleteRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> Get DeleteRowsEvent -getDeleteRowEvent fd tme typ = do +decodeDeleteRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> P.Parser DeleteRowsEvent +decodeDeleteRowEvent fd tme typ = do let hlen = eventHeaderLen fd typ - tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le - flgs <- getWord16le + tid <- if hlen == 6 then fromIntegral <$> P.decodePrimLE @Word32 else decodeWord48LE + flgs <- P.decodePrimLE @Word16 when (typ == BINLOG_DELETE_ROWS_EVENTv2) $ do - extraLen <- getWord16le - void $ getByteString (fromIntegral extraLen - 2) - colCnt <- getLenEncInt + extraLen <- P.decodePrimLE @Word16 + void $ P.take (fromIntegral extraLen - 2) + colCnt <- decodeLenEncInt let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8 - pmap <- getPresentMap plen poffset - DeleteRowsEvent tid flgs colCnt pmap <$> untilM (getBinLogRow (tmColumnMeta tme) pmap) isEmpty + pmap <- decodePresentMap plen poffset + DeleteRowsEvent tid flgs colCnt pmap <$> untilM (decodeBinLogRow (tmColumnMeta tme) pmap) P.atEnd data WriteRowsEvent = WriteRowsEvent { writeTableId :: !Word64 @@ -243,18 +234,18 @@ data WriteRowsEvent = WriteRowsEvent , writeRowData :: ![[BinLogValue]] } deriving (Show, Eq, Generic) -getWriteRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> Get WriteRowsEvent -getWriteRowEvent fd tme typ = do +decodeWriteRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> P.Parser WriteRowsEvent +decodeWriteRowEvent fd tme typ = do let hlen = eventHeaderLen fd typ - tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le - flgs <- getWord16le + tid <- if hlen == 6 then fromIntegral <$> P.decodePrimLE @Word32 else decodeWord48LE + flgs <- P.decodePrimLE @Word16 when (typ == BINLOG_WRITE_ROWS_EVENTv2) $ do - extraLen <- getWord16le - void $ getByteString (fromIntegral extraLen - 2) - colCnt <- getLenEncInt + extraLen <- P.decodePrimLE @Word16 + void $ P.take (fromIntegral extraLen - 2) + colCnt <- decodeLenEncInt let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8 - pmap <- getPresentMap plen poffset - WriteRowsEvent tid flgs colCnt pmap <$> untilM (getBinLogRow (tmColumnMeta tme) pmap) isEmpty + pmap <- decodePresentMap plen poffset + WriteRowsEvent tid flgs colCnt pmap <$> untilM (decodeBinLogRow (tmColumnMeta tme) pmap) P.atEnd data UpdateRowsEvent = UpdateRowsEvent { updateTableId :: !Word64 @@ -265,27 +256,27 @@ data UpdateRowsEvent = UpdateRowsEvent , updateRowData :: ![ ([BinLogValue], [BinLogValue]) ] } deriving (Show, Eq, Generic) -getUpdateRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> Get UpdateRowsEvent -getUpdateRowEvent fd tme typ = do +decodeUpdateRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> P.Parser UpdateRowsEvent +decodeUpdateRowEvent fd tme typ = do let hlen = eventHeaderLen fd typ - tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le - flgs <- getWord16le + tid <- if hlen == 6 then fromIntegral <$> P.decodePrimLE @Word32 else decodeWord48LE + flgs <- P.decodePrimLE @Word16 when (typ == BINLOG_UPDATE_ROWS_EVENTv2) $ do - extraLen <- getWord16le - void $ getByteString (fromIntegral extraLen - 2) - colCnt <- getLenEncInt + extraLen <- P.decodePrimLE @Word16 + void $ P.take (fromIntegral extraLen - 2) + colCnt <- decodeLenEncInt let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8 - pmap <- getPresentMap plen poffset - pmap' <- getPresentMap plen poffset + pmap <- decodePresentMap plen poffset + pmap' <- decodePresentMap plen poffset UpdateRowsEvent tid flgs colCnt (pmap, pmap') <$> - untilM ((,) <$> getBinLogRow (tmColumnMeta tme) pmap <*> getBinLogRow (tmColumnMeta tme) pmap') - isEmpty - -getPresentMap :: Int -> Int -> Get BitMap -getPresentMap plen poffset = do - pmap <- getByteString plen - let pmap' = if B.null pmap - then B.empty - else B.init pmap `B.snoc` (B.last pmap .&. 0xFF `shiftR` (7 - poffset)) + untilM ((,) <$> decodeBinLogRow (tmColumnMeta tme) pmap <*> decodeBinLogRow (tmColumnMeta tme) pmap') + P.atEnd + +decodePresentMap :: Int -> Int -> P.Parser BitMap +decodePresentMap plen poffset = do + pmap <- P.take plen + let pmap' = if V.null pmap + then V.empty + else V.init pmap `V.snoc` (V.last pmap .&. 0xFF `shiftR` (7 - poffset)) pure (BitMap pmap') diff --git a/Database/MySQL/BinLogProtocol/BinLogMeta.hs b/Database/MySQL/BinLogProtocol/BinLogMeta.hs index c88eb43..f3e36b5 100644 --- a/Database/MySQL/BinLogProtocol/BinLogMeta.hs +++ b/Database/MySQL/BinLogProtocol/BinLogMeta.hs @@ -29,9 +29,14 @@ You will not directly meet following 'FieldType' namely: module Database.MySQL.BinLogProtocol.BinLogMeta where import Control.Applicative -import Data.Binary.Get import Data.Bits import Data.Word +import qualified Z.Data.Parser as P +import qualified Z.Data.Builder as B +import qualified Z.Data.Text.Base as T +import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Extra as V import Database.MySQL.Protocol.ColumnDef -- | An intermedia date type for decoding row-based event's values. @@ -62,59 +67,59 @@ data BinLogMeta | BINLOG_TYPE_GEOMETRY !Word8 -- ^ length size deriving (Show, Eq) -getBinLogMeta :: FieldType -> Get BinLogMeta -getBinLogMeta t - | t == mySQLTypeTiny = pure BINLOG_TYPE_TINY - | t == mySQLTypeShort = pure BINLOG_TYPE_SHORT - | t == mySQLTypeInt24 = pure BINLOG_TYPE_INT24 - | t == mySQLTypeLong = pure BINLOG_TYPE_LONG - | t == mySQLTypeLongLong = pure BINLOG_TYPE_LONGLONG - | t == mySQLTypeFloat = BINLOG_TYPE_FLOAT <$> getWord8 - | t == mySQLTypeDouble = BINLOG_TYPE_DOUBLE <$> getWord8 +decodeBinLogMeta :: FieldType -> P.Parser BinLogMeta +decodeBinLogMeta t + | t == MySQLTypeTiny = pure BINLOG_TYPE_TINY + | t == MySQLTypeShort = pure BINLOG_TYPE_SHORT + | t == MySQLTypeInt24 = pure BINLOG_TYPE_INT24 + | t == MySQLTypeLong = pure BINLOG_TYPE_LONG + | t == MySQLTypeLongLong = pure BINLOG_TYPE_LONGLONG + | t == MySQLTypeFloat = BINLOG_TYPE_FLOAT <$> P.anyWord8 + | t == MySQLTypeDouble = BINLOG_TYPE_DOUBLE <$> P.anyWord8 - | t == mySQLTypeBit = do - byte0 <- getWord8 - byte1 <- getWord8 + | t == MySQLTypeBit = do + byte0 <- P.anyWord8 + byte1 <- P.anyWord8 let nbits = (fromIntegral byte1 `shiftL` 3) .|. fromIntegral byte0 nbytes = fromIntegral $ (nbits + 7) `shiftR` 3 pure (BINLOG_TYPE_BIT nbits nbytes) - | t == mySQLTypeTimestamp = pure BINLOG_TYPE_TIMESTAMP - | t == mySQLTypeDateTime = pure BINLOG_TYPE_DATETIME - | t == mySQLTypeDate = pure BINLOG_TYPE_DATE - | t == mySQLTypeTime = pure BINLOG_TYPE_TIME - | t == mySQLTypeTimestamp2 = BINLOG_TYPE_TIMESTAMP2 <$> getWord8 - | t == mySQLTypeDateTime2 = BINLOG_TYPE_DATETIME2 <$> getWord8 - | t == mySQLTypeTime2 = BINLOG_TYPE_TIME2 <$> getWord8 - | t == mySQLTypeYear = pure BINLOG_TYPE_YEAR - | t == mySQLTypeNewDecimal = BINLOG_TYPE_NEWDECIMAL <$> getWord8 <*> getWord8 - | t == mySQLTypeVarChar = BINLOG_TYPE_STRING <$> getWord16le - | t == mySQLTypeVarString = BINLOG_TYPE_STRING <$> getWord16le + | t == MySQLTypeTimestamp = pure BINLOG_TYPE_TIMESTAMP + | t == MySQLTypeDateTime = pure BINLOG_TYPE_DATETIME + | t == MySQLTypeDate = pure BINLOG_TYPE_DATE + | t == MySQLTypeTime = pure BINLOG_TYPE_TIME + | t == MySQLTypeTimestamp2 = BINLOG_TYPE_TIMESTAMP2 <$> P.anyWord8 + | t == MySQLTypeDateTime2 = BINLOG_TYPE_DATETIME2 <$> P.anyWord8 + | t == MySQLTypeTime2 = BINLOG_TYPE_TIME2 <$> P.anyWord8 + | t == MySQLTypeYear = pure BINLOG_TYPE_YEAR + | t == MySQLTypeNewDecimal = BINLOG_TYPE_NEWDECIMAL <$> P.anyWord8 <*> P.anyWord8 + | t == MySQLTypeVarChar = BINLOG_TYPE_STRING <$> P.decodePrimLE + | t == MySQLTypeVarString = BINLOG_TYPE_STRING <$> P.decodePrimLE - | t == mySQLTypeString = do - byte0 <- getWord8 - byte1 <- getWord8 + | t == MySQLTypeString = do + byte0 <- P.anyWord8 + byte1 <- P.anyWord8 -- http://bugs.mysql.com/37426 if byte0 > 0 then if (byte0 .&. 0x30) /= 0x30 - then if FieldType (byte0 .|. 0x30) == mySQLTypeString + then if (byte0 .|. 0x30) == MySQLTypeString then let len = fromIntegral $ (byte0 .&. 0x30) `xor` 0x30 len' = len `shiftL` 4 .|. fromIntegral byte1 in pure $! BINLOG_TYPE_STRING len' else let len = fromIntegral byte0 `shiftL` 8 :: Word16 len' = len .|. fromIntegral byte1 in pure $! BINLOG_TYPE_STRING len' - else let t' = FieldType byte0 - in if | t' == mySQLTypeSet -> let nbits = fromIntegral byte1 `shiftL` 3 + else let t' = byte0 + in if | t' == MySQLTypeSet -> let nbits = fromIntegral byte1 `shiftL` 3 nbytes = fromIntegral $ (nbits + 7) `shiftR` 8 in pure (BINLOG_TYPE_SET nbits nbytes) - | t' == mySQLTypeEnum -> pure (BINLOG_TYPE_ENUM byte1) - | t' == mySQLTypeString -> pure (BINLOG_TYPE_STRING (fromIntegral byte1)) - | otherwise -> fail $ "Database.MySQL.BinLogProtocol.BinLogMeta:\ - \ impossible type inside binlog string: " ++ show t' + | t' == MySQLTypeEnum -> pure (BINLOG_TYPE_ENUM byte1) + | t' == MySQLTypeString -> pure (BINLOG_TYPE_STRING (fromIntegral byte1)) + | otherwise -> P.fail' $ "Database.MySQL.BinLogProtocol.BinLogMeta:\ + \ impossible type inside binlog string: " <> T.toText t' else pure (BINLOG_TYPE_STRING (fromIntegral byte1)) - | t == mySQLTypeBlob = BINLOG_TYPE_BLOB <$> getWord8 - | t == mySQLTypeGeometry = BINLOG_TYPE_GEOMETRY <$> getWord8 - | otherwise = fail $ "Database.MySQL.BinLogProtocol.BinLogMeta:\ - \ impossible type in binlog: " ++ show t + | t == MySQLTypeBlob = BINLOG_TYPE_BLOB <$> P.anyWord8 + | t == MySQLTypeGeometry = BINLOG_TYPE_GEOMETRY <$> P.anyWord8 + | otherwise = P.fail' $ "Database.MySQL.BinLogProtocol.BinLogMeta:\ + \ impossible type in binlog: " <> T.toText t diff --git a/Database/MySQL/BinLogProtocol/BinLogValue.hs b/Database/MySQL/BinLogProtocol/BinLogValue.hs index a93a4ba..e42cfc3 100644 --- a/Database/MySQL/BinLogProtocol/BinLogValue.hs +++ b/Database/MySQL/BinLogProtocol/BinLogValue.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + {-| Module : Database.MySQL.BinLogProtocol.BinLogValue Description : Binlog protocol @@ -14,13 +16,7 @@ Binlog protocol 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) -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B import Data.Int import Data.Int.Int24 import Data.Scientific @@ -29,6 +25,11 @@ import Database.MySQL.BinLogProtocol.BinLogMeta import Database.MySQL.Protocol.MySQLValue import Database.MySQL.Protocol.Packet import GHC.Generics (Generic) +import qualified Z.Data.Parser as P +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Extra as V -- | Data type for representing binlog values. -- @@ -46,7 +47,7 @@ import GHC.Generics (Generic) -- Timestamp types('BinLogTimeStamp' and 'BinLogTimeStamp2') are values converted into UTC already, -- see 'MySQLVaule' 's note. -- --- There's also no infomation about charset, so we use 'ByteString' to present both text +-- There's also no infomation about charset, so we use 'V.Bytes' to present both text -- and blob types, if you want to get text representation back, you have to query column charset -- infomation, and use icu or iconv to decode. IT MAY NOT BE UTF-8. -- @@ -75,44 +76,44 @@ data BinLogValue | BinLogNewDecimal !Scientific -- ^ sign(1= non-negative, 0= negative) integeral part, fractional part | BinLogEnum !Word16 -- ^ enum indexing value | BinLogSet !Word64 -- ^ set indexing 64bit bitmap. - | BinLogBytes !ByteString -- ^ all string and blob values. - | BinLogGeometry !ByteString + | BinLogBytes !V.Bytes -- ^ all string and blob values. + | BinLogGeometry !V.Bytes | BinLogNull deriving (Show, Eq, Generic) -------------------------------------------------------------------------------- -- | BinLog protocol decoder -- -getBinLogField :: BinLogMeta -> Get BinLogValue -getBinLogField BINLOG_TYPE_TINY = BinLogTiny <$> getInt8 -getBinLogField BINLOG_TYPE_SHORT = BinLogShort <$> getInt16le -getBinLogField BINLOG_TYPE_INT24 = BinLogInt24 . fromIntegral <$> getWord24le -getBinLogField BINLOG_TYPE_LONG = BinLogLong <$> getInt32le -getBinLogField BINLOG_TYPE_LONGLONG = BinLogLongLong <$> getInt64le -getBinLogField (BINLOG_TYPE_FLOAT _ ) = BinLogFloat <$> getFloatle -getBinLogField (BINLOG_TYPE_DOUBLE _ ) = BinLogDouble <$> getDoublele -getBinLogField (BINLOG_TYPE_BIT _ bytes) = BinLogBit <$> getBits' bytes -getBinLogField BINLOG_TYPE_TIMESTAMP = BinLogTimeStamp <$> getWord32le +decodeBinLogField :: BinLogMeta -> P.Parser BinLogValue +decodeBinLogField BINLOG_TYPE_TINY = BinLogTiny <$> P.decodePrim @Int8 +decodeBinLogField BINLOG_TYPE_SHORT = BinLogShort <$> P.decodePrimLE +decodeBinLogField BINLOG_TYPE_INT24 = BinLogInt24 . fromIntegral <$> decodeWord24LE +decodeBinLogField BINLOG_TYPE_LONG = BinLogLong <$> P.decodePrimLE +decodeBinLogField BINLOG_TYPE_LONGLONG = BinLogLongLong <$> P.decodePrimLE +decodeBinLogField (BINLOG_TYPE_FLOAT _ ) = BinLogFloat <$> P.decodePrimLE +decodeBinLogField (BINLOG_TYPE_DOUBLE _ ) = BinLogDouble <$> P.decodePrimLE +decodeBinLogField (BINLOG_TYPE_BIT _ bytes) = BinLogBit <$> decodeBits' bytes +decodeBinLogField BINLOG_TYPE_TIMESTAMP = BinLogTimeStamp <$> P.decodePrimLE -- A integer in @YYYYMMDD@ format, for example: -- 99991231 stand for @9999-12-31@ -getBinLogField BINLOG_TYPE_DATE = do - i <- getWord24le +decodeBinLogField BINLOG_TYPE_DATE = do + i <- decodeWord24LE let (i', dd) = i `quotRem` 32 (yyyy, mm) = i' `quotRem` 16 pure (BinLogDate (fromIntegral yyyy) (fromIntegral mm) (fromIntegral dd)) -getBinLogField (BINLOG_TYPE_TIMESTAMP2 fsp) = do - s <- getWord32be -- big-endian here! - ms <- fromIntegral <$> getMicroSecond fsp +decodeBinLogField (BINLOG_TYPE_TIMESTAMP2 fsp) = do + s <- P.decodePrimBE @Word32 -- big-endian here! + ms <- fromIntegral <$> decodeMicroSecond fsp pure (BinLogTimeStamp2 s ms) -- A integer in @YYYYMMDDhhmmss@, for example: -- 99991231235959 stand for @9999-12-31 23:59:59@ -getBinLogField BINLOG_TYPE_DATETIME = do - i <- getWord64le +decodeBinLogField BINLOG_TYPE_DATETIME = do + i <- P.decodePrimLE @Word64 let (yyyy, i') = i `quotRem` 10000000000 (mm, i'') = i' `quotRem` 100000000 (dd, i''') = i'' `quotRem` 1000000 @@ -137,8 +138,8 @@ getBinLogField BINLOG_TYPE_DATETIME = do -- -- fractional-seconds storage (size depends on meta) -- -getBinLogField (BINLOG_TYPE_DATETIME2 fsp) = do - iPart <- getWord40be +decodeBinLogField (BINLOG_TYPE_DATETIME2 fsp) = do + iPart <- decodeWord40BE let yyyymm = iPart `shiftR` 22 .&. 0x01FFFF -- 0b011111111111111111 (yyyy, mm) = yyyymm `quotRem` 13 yyyy' = fromIntegral yyyy @@ -147,13 +148,13 @@ getBinLogField (BINLOG_TYPE_DATETIME2 fsp) = do h = fromIntegral $ iPart `shiftR` 12 .&. 0x1F -- 0b00011111 m = fromIntegral $ iPart `shiftR` 6 .&. 0x3F -- 0b00111111 s = fromIntegral $ iPart .&. 0x3F -- 0b00111111 - ms <- fromIntegral <$> getMicroSecond fsp + ms <- fromIntegral <$> decodeMicroSecond fsp pure (BinLogDateTime2 yyyy' mm' dd h m s ms) -- A integer in @hhmmss@ format(can be negative), for example: -- 8385959 stand for @838:59:59@ -getBinLogField BINLOG_TYPE_TIME = do - i <- getWord24le +decodeBinLogField BINLOG_TYPE_TIME = do + i <- decodeWord24LE let i' = fromIntegral i :: Int24 sign = if i' >= 0 then 1 else 0 let (h, i'') = i' `quotRem` 10000 @@ -173,19 +174,19 @@ getBinLogField BINLOG_TYPE_TIME = do -- -- fractional-seconds storage (size depends on meta) -- -getBinLogField (BINLOG_TYPE_TIME2 fsp) = do - iPart <- getWord24be +decodeBinLogField (BINLOG_TYPE_TIME2 fsp) = do + iPart <- decodeWord24BE let sign = fromIntegral $ iPart `shiftR` 23 iPart' = if sign == 0 then 0x800000 - iPart - 1 else iPart h = fromIntegral (iPart' `shiftR` 12) .&. 0x03FF -- 0b0000001111111111 m = fromIntegral (iPart' `shiftR` 6) .&. 0x3F -- 0b00111111 s = fromIntegral iPart' .&. 0x3F -- 0b00111111 - ms <- abs <$> getMicroSecond fsp + ms <- abs <$> decodeMicroSecond fsp let ms' = abs (fromIntegral ms :: Int) pure (BinLogTime2 sign h m s (fromIntegral ms')) -getBinLogField BINLOG_TYPE_YEAR = do - y <- getWord8 +decodeBinLogField BINLOG_TYPE_YEAR = do + y <- P.anyWord8 pure $! if y == 0 then BinLogYear 0 else BinLogYear (1900 + fromIntegral y) -- Decimal representation in binlog seems to be as follows: @@ -205,31 +206,31 @@ getBinLogField BINLOG_TYPE_YEAR = do -- if there're < 9 digits at first, it will be compressed into suitable length words -- following a simple lookup table. -- -getBinLogField (BINLOG_TYPE_NEWDECIMAL precision scale) = do +decodeBinLogField (BINLOG_TYPE_NEWDECIMAL precision scale) = do let i = fromIntegral (precision - scale) (ucI, cI) = i `quotRem` digitsPerInteger - (ucF, cF) = scale `quotRem` digitsPerInteger - ucISize = fromIntegral (ucI `shiftL` 2) - ucFSize = fromIntegral (ucF `shiftL` 2) - cISize = fromIntegral (sizeTable `B.unsafeIndex` fromIntegral cI) - cFSize = fromIntegral (sizeTable `B.unsafeIndex` fromIntegral cF) + (ucF, cF) = fromIntegral scale `quotRem` digitsPerInteger + ucISize = (ucI `shiftL` 2) + ucFSize = (ucF `shiftL` 2) + cISize = (sizeTable `V.unsafeIndex` cI) + cFSize = (sizeTable `V.unsafeIndex` cF) len = ucISize + cISize + ucFSize + cFSize - buf <- getByteString (fromIntegral len) + buf <- P.take (fromIntegral len) - let fb = buf `B.unsafeIndex` 0 + let fb = buf `V.unsafeIndex` 0 sign = if fb .&. 0x80 == 0x80 then 1 else 0 :: Word8 - buf' = (fb `xor` 0x80) `B.cons` B.tail buf + buf' = (fb `xor` 0x80) `V.cons` V.tail buf buf'' = if sign == 1 then buf' - else B.map (xor 0xFF) buf' + else V.map (xor 0xFF) buf' - iPart = fromIntegral (getCompressed cISize (B.unsafeTake cISize buf'')) * (blockSize ^ ucI) - + getUncompressed ucI (B.unsafeDrop cISize buf'') + iPart = fromIntegral (decodeCompressed cISize (V.unsafeTake cISize buf'')) * (blockSize ^ ucI) + + decodeUncompressed ucI (V.unsafeDrop cISize buf'') - let buf''' = B.unsafeDrop (ucISize + cISize) buf'' + let buf''' = V.unsafeDrop (ucISize + cISize) buf'' - fPart = getUncompressed ucF (B.unsafeTake ucFSize buf''') * (10 ^ cF) - + fromIntegral (getCompressed cFSize (B.unsafeDrop ucFSize buf''')) + fPart = decodeUncompressed ucF (V.unsafeTake ucFSize buf''') * (10 ^ cF) + + fromIntegral (decodeCompressed cFSize (V.unsafeDrop ucFSize buf''')) let sci = scientific (iPart * 10 ^ scale + fPart) (negate $ fromIntegral scale) sci' = if sign == 0 then negate sci else sci @@ -237,89 +238,91 @@ getBinLogField (BINLOG_TYPE_NEWDECIMAL precision scale) = do where digitsPerInteger = 9 blockSize = fromIntegral $ (10 :: Int32) ^ (9 :: Int) - sizeTable = B.pack [0, 1, 1, 2, 2, 3, 3, 4, 4, 4] - - getCompressed :: Int -> ByteString -> Word64 - getCompressed 0 _ = 0 - getCompressed x bs = let fb = bs `B.unsafeIndex` 0 - x' = x - 1 - in fromIntegral fb `shiftL` (8 * x') .|. getCompressed x' (B.unsafeDrop 1 bs) - - getUncompressed :: Word8 -> ByteString -> Integer - getUncompressed 0 _ = 0 - getUncompressed x bs = let v = getCompressed 4 (B.unsafeTake 4 bs) - x' = x - 1 - in fromIntegral v * (blockSize ^ x') + getUncompressed x' (B.unsafeDrop 4 bs) - - -getBinLogField (BINLOG_TYPE_ENUM size) = - if | size == 1 -> BinLogEnum . fromIntegral <$> getWord8 - | size == 2 -> BinLogEnum . fromIntegral <$> getWord16be - | otherwise -> fail $ "Database.MySQL.BinLogProtocol.BinLogValue: wrong \ - \BINLOG_TYPE_ENUM size: " ++ show size - - -getBinLogField (BINLOG_TYPE_SET _ bytes) = BinLogSet <$> getBits' bytes -getBinLogField (BINLOG_TYPE_BLOB lensize) = do - len <- if | lensize == 1 -> fromIntegral <$> getWord8 - | lensize == 2 -> fromIntegral <$> getWord16le - | lensize == 3 -> fromIntegral <$> getWord24le - | lensize == 4 -> fromIntegral <$> getWord32le - | otherwise -> fail $ "Database.MySQL.BinLogProtocol.BinLogValue: \ - \wrong BINLOG_TYPE_BLOB length size: " ++ show lensize - BinLogBytes <$> getByteString len - -getBinLogField (BINLOG_TYPE_STRING size) = do - len <- if | size < 256 -> fromIntegral <$> getWord8 - | otherwise -> fromIntegral <$> getWord16le - BinLogBytes <$> getByteString len - -getBinLogField (BINLOG_TYPE_GEOMETRY lensize) = do - len <- if | lensize == 1 -> fromIntegral <$> getWord8 - | lensize == 2 -> fromIntegral <$> getWord16le - | lensize == 3 -> fromIntegral <$> getWord24le - | lensize == 4 -> fromIntegral <$> getWord32le - | otherwise -> fail $ "Database.MySQL.BinLogProtocol.BinLogValue: \ - \wrong BINLOG_TYPE_GEOMETRY length size: " ++ show lensize - BinLogGeometry <$> getByteString len - -getMicroSecond :: Word8 -> Get Int32 -getMicroSecond 0 = pure 0 -getMicroSecond 1 = (* 100000) . fromIntegral <$> getInt8 -getMicroSecond 2 = (* 10000) . fromIntegral <$> getInt8 -getMicroSecond 3 = (* 1000) . fromIntegral <$> getInt16be -getMicroSecond 4 = (* 100) . fromIntegral <$> getInt16be -getMicroSecond 5 = (* 10) . fromIntegral <$> getInt24be -getMicroSecond 6 = fromIntegral <$> getInt24be -getMicroSecond _ = pure 0 - -getBits' :: Word8 -> Get Word64 -getBits' bytes = if bytes <= 8 - then getBits (fromIntegral bytes) - else fail $ "Database.MySQL.BinLogProtocol.BinLogValue: \ - \wrong bit length size: " ++ show bytes + sizeTable :: V.PrimVector Int + sizeTable = V.pack [0, 1, 1, 2, 2, 3, 3, 4, 4, 4] + + decodeCompressed :: Int -> V.Bytes -> Word64 + decodeCompressed 0 _ = 0 + decodeCompressed x bs = let !fb = bs `V.unsafeIndex` 0 + !x' = x - 1 + in fromIntegral fb `shiftL` (8 * x') .|. decodeCompressed x' (V.unsafeDrop 1 bs) + + decodeUncompressed :: Int -> V.Bytes -> Integer + decodeUncompressed 0 _ = 0 + decodeUncompressed x bs = let !v = decodeCompressed 4 (V.unsafeTake 4 bs) + !x' = x - 1 + in fromIntegral v * (blockSize ^ x') + decodeUncompressed x' (V.unsafeDrop 4 bs) + + +decodeBinLogField (BINLOG_TYPE_ENUM size) = + if | size == 1 -> BinLogEnum . fromIntegral <$> P.anyWord8 + | size == 2 -> BinLogEnum . fromIntegral <$> P.decodePrimLE @Word16 + | otherwise -> P.fail' $ "Database.MySQL.BinLogProtocol.BinLogValue: wrong \ + \BINLOG_TYPE_ENUM size: " <> T.toText size + + +decodeBinLogField (BINLOG_TYPE_SET _ bytes) = BinLogSet <$> decodeBits' bytes +decodeBinLogField (BINLOG_TYPE_BLOB lensize) = do + len <- if | lensize == 1 -> fromIntegral <$> P.anyWord8 + | lensize == 2 -> fromIntegral <$> P.decodePrimLE @Word16 + | lensize == 3 -> fromIntegral <$> decodeWord24LE + | lensize == 4 -> fromIntegral <$> P.decodePrimLE @Word32 + | otherwise -> P.fail' $ "Database.MySQL.BinLogProtocol.BinLogValue: \ + \wrong BINLOG_TYPE_BLOB length size: " <> T.toText lensize + BinLogBytes <$> P.take len + +decodeBinLogField (BINLOG_TYPE_STRING size) = do + len <- if | size < 256 -> fromIntegral <$> P.anyWord8 + | otherwise -> fromIntegral <$> P.decodePrimLE @Word16 + BinLogBytes <$> P.take len + +decodeBinLogField (BINLOG_TYPE_GEOMETRY lensize) = do + len <- if | lensize == 1 -> fromIntegral <$> P.anyWord8 + | lensize == 2 -> fromIntegral <$> P.decodePrimLE @Word16 + | lensize == 3 -> fromIntegral <$> decodeWord24LE + | lensize == 4 -> fromIntegral <$> P.decodePrimLE @Word32 + | otherwise -> P.fail' $ "Database.MySQL.BinLogProtocol.BinLogValue: \ + \wrong BINLOG_TYPE_GEOMETRY length size: " <> T.toText lensize + BinLogGeometry <$> P.take len + +decodeMicroSecond :: Word8 -> P.Parser Int32 +decodeMicroSecond 0 = pure 0 +decodeMicroSecond 1 = (* 100000) . fromIntegral <$> P.decodePrim @Int8 +decodeMicroSecond 2 = (* 10000) . fromIntegral <$> P.decodePrim @Int8 +decodeMicroSecond 3 = (* 1000) . fromIntegral <$> P.decodePrimBE @Int16 +decodeMicroSecond 4 = (* 100) . fromIntegral <$> P.decodePrimBE @Int16 +decodeMicroSecond 5 = (* 10) . fromIntegral <$> decodeInt24BE +decodeMicroSecond 6 = fromIntegral <$> decodeInt24BE +decodeMicroSecond _ = pure 0 + +decodeBits' :: Word8 -> P.Parser Word64 +decodeBits' bytes = if bytes <= 8 + then decodeBits (fromIntegral bytes) + else P.fail' $ "Database.MySQL.BinLogProtocol.BinLogValue: wrong bit length size: " <> T.toText bytes -------------------------------------------------------------------------------- -- | BinLog row decoder -- -getBinLogRow :: [BinLogMeta] -> BitMap -> Get [BinLogValue] -getBinLogRow metas pmap = do - let plen = B.foldl' (\acc word8 -> acc + popCount word8) 0 (fromBitMap pmap) +decodeBinLogRow :: V.Vector BinLogMeta -> BitMap -> P.Parser [BinLogValue] +decodeBinLogRow metas pmap = do + let plen = V.foldl' (\acc word8 -> acc + popCount word8) 0 (fromBitMap pmap) maplen = (plen + 7) `shiftR` 3 - nullmap <- getByteString maplen - go metas (BitMap nullmap) 0 pmap 0 + nullmap <- P.take maplen + go (BitMap nullmap) (V.length metas) 0 0 where - go :: [BinLogMeta] -> BitMap -> Int -> BitMap -> Int -> Get [BinLogValue] - go [] _ _ _ _ = pure [] - go (f:fs) nullmap nullpos pmap' ppos = do - let ppos' = ppos + 1 - if isColumnSet pmap' ppos - then do - r <- if isColumnSet nullmap nullpos - then return BinLogNull - else getBinLogField f - let nullpos' = nullpos + 1 - rest <- nullpos' `seq` ppos' `seq` go fs nullmap nullpos' pmap' ppos' - return (rest `seq` (r : rest)) - else ppos' `seq` go fs nullmap nullpos pmap' ppos' + go :: BitMap -> Int -> Int -> Int -> P.Parser [BinLogValue] + go nullmap end !nullpos !ppos + | ppos >= end = pure [] + | otherwise = do + let f = metas `V.unsafeIndex` ppos + ppos' = ppos + 1 + if isColumnSet pmap ppos + then do + r <- if isColumnSet nullmap nullpos + then return BinLogNull + else decodeBinLogField f + let nullpos' = nullpos + 1 + rest <- go nullmap end nullpos' ppos' + return (rest `seq` (r : rest)) + else go nullmap end nullpos ppos' diff --git a/Database/MySQL/Connection.hs b/Database/MySQL/Connection.hs index 4f4b256..2ecefb3 100644 --- a/Database/MySQL/Connection.hs +++ b/Database/MySQL/Connection.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-| Module : Database.MySQL.Connection Description : Connection managment @@ -21,6 +22,7 @@ import Data.Word import GHC.Generics import qualified Z.Crypto.Hash as Crypto import Z.Crypto.SafeMem +import Z.Crypto.PubKey import qualified Z.Data.Parser as P import qualified Z.Data.Builder as B import qualified Z.Data.Text as T @@ -49,13 +51,16 @@ data MySQLConn = MySQLConn -- -- data ConnectInfo = ConnectInfo - { ciConfig :: Either IPCClientConfig TCPClientConfig + { ciConnConfig :: Either IPCClientConfig TCPClientConfig , ciRecvBufSiz :: Int , ciSendBufSiz :: Int , ciDatabase :: T.Text , ciUser :: T.Text , ciPassword :: T.Text , ciCharset :: Word8 + , ciSecureConf :: Maybe PubKey -- ^ MySQL 8.0.2 and afterward, the default authentication plugin is @caching_sha2_password@, + -- set this field to the server's public key if you're not using TLS connection and don't want + -- request public key from server over non-secure wire. } deriving Show -- | A simple 'ConnectInfo' targeting localhost with @user=root@ and empty password. @@ -69,7 +74,7 @@ defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnectInfo (Right defaultTCPClientConfig{ tcpRemoteAddr = SocketAddrIPv4 ipv4Loopback 3306 }) defaultChunkSize defaultChunkSize - "" "root" "" utf8_general_ci + "" "root" "" utf8_general_ci Nothing -- | 'defaultConnectInfo' with charset set to @utf8mb4_unicode_ci@ -- @@ -79,7 +84,7 @@ defaultConnectInfoMB4 :: ConnectInfo defaultConnectInfoMB4 = ConnectInfo (Right defaultTCPClientConfig{ tcpRemoteAddr = SocketAddrIPv4 ipv4Loopback 3306 }) defaultChunkSize defaultChunkSize - "" "root" "" utf8mb4_unicode_ci + "" "root" "" utf8mb4_unicode_ci Nothing utf8_general_ci :: Word8 utf8_general_ci = 33 @@ -104,16 +109,14 @@ connect = fmap snd . connectDetail -- | Establish a MySQL connection with 'Greeting' back, so you can find server's version .etc. -- connectDetail :: HasCallStack => ConnectInfo -> Resource (Greeting, MySQLConn) -connectDetail (ConnectInfo conf recvBufSiz sendBufSiz db user pass charset) = do +connectDetail (ConnectInfo conf recvBufSiz sendBufSiz db user (T.getUTF8Bytes -> pass) charset mpubkey) = do uvs <- either initIPCClient initTCPClient conf initResource (do (bi, bo) <- newBufferedIO' uvs recvBufSiz sendBufSiz - p <- readPacket bi - greet <- decodeFromPacket decodeGreeting p - let auth = mkAuth (T.getUTF8Bytes db) (T.getUTF8Bytes user) (T.getUTF8Bytes pass) charset greet - writeBuilder bo $ encodePacket (encodeToPacket 1 (encodeAuth auth)) + greet <- decodeFromPacket decodeGreeting =<< readPacket bi + writeBuilder bo $ encodePacket (encodeToPacket 1 (encodeHandshakeResponse41 (mkAuth41 greet))) flushBuffer bo - _ <- readPacket bi -- OK + handleAuthRes greet bi bo consumed <- newIORef True return (greet, MySQLConn bi bo consumed)) (\ (_, MySQLConn bi bo _) -> writeCommand COM_QUIT bo >> waitNotMandatoryOK bi) @@ -122,29 +125,61 @@ connectDetail (ConnectInfo conf recvBufSiz sendBufSiz db user pass charset) = do (void (waitCommandReply bi)) -- server will either reply an OK packet ((\ _ -> return ()) :: SomeException -> IO ()) -- or directy close the connection -mkAuth :: V.Bytes -> V.Bytes -> V.Bytes -> Word8 -> Greeting -> Auth -mkAuth db user pass charset greet = - let salt = greetingSalt1 greet `V.append` greetingSalt2 greet - plugin = greetingAuthPlugin greet - scambleBuf = scramble plugin salt pass - in Auth clientCap clientMaxPacketSize charset user scambleBuf db plugin - where - scramble :: V.Bytes -> V.Bytes -> V.Bytes -> V.Bytes - scramble plugin salt pass' - | V.null pass' = V.empty + -- | Make a HandshakeResponse41 packet + mkAuth41 greet = + let salt = greetingSalt1 greet `V.append` greetingSalt2 greet + plugin = greetingAuthPlugin greet + scambleBuf = scramble plugin salt + in HandshakeResponse41 clientCap clientMaxPacketSize charset user scambleBuf db plugin + + handleAuthRes greet bi bo = do + authRes <- readPacket bi + + when (isAuthSwitchRequest authRes) $ do + -- TODO, update greet packet? + (AuthSwitchRequest plugin salt) <- decodeFromPacket decodeAuthSwitchRequest authRes + let scambleBuf = scramble plugin salt + writeBuilder bo $ encodePacket (Packet (V.length scambleBuf) 3 scambleBuf) + flushBuffer bo + handleAuthRes greet bi bo + + when (isAuthResponse authRes) $ do + case decodeAuthResponse authRes of + PerformFullAuthentication -> do + -- Request pubkey from server, see https://mariadb.com/kb/en/caching_sha2_password-authentication-plugin/#public-key-request + pubkey <- maybe + (do let pubkeyRequest = Packet 1 3 (V.singleton 2) + decodePubKey = do + P.skipWord8 -- 0x01 + P.takeRemaining + writeBuilder bo $ encodePacket pubkeyRequest + flushBuffer bo + loadPubKey =<< decodeFromPacket decodePubKey =<< readPacket bi) return mpubkey + rng <- getRNG + let salt = greetingSalt1 greet `V.append` greetingSalt2 greet + encryptedPass <- if V.null pass + then return V.empty + else pkEncrypt pubkey (EME_OAEP SHA160 "") rng (V.zipWith' xor (pass `V.snoc` 0) salt) + writeBuilder bo $ encodePacket (Packet 256 5 encryptedPass) + flushBuffer bo + _ -> return () + handleAuthRes greet bi bo + + -- Now by pass OK packet + + scramble :: T.Text -> V.Bytes -> V.Bytes + scramble plugin salt + | V.null pass = V.empty | otherwise = case plugin of - "caching_sha2_password" -> V.zipWith' xor sha2pass salt2 - "mysql_native_password" -> V.zipWith' xor sha1pass salt1 - _ -> "" - where sha1pass = sha1 pass' - salt1 = sha1 (salt `V.append` sha1 sha1pass) - sha2pass = sha2 pass' - salt2 = sha1 (salt `V.append` sha2 sha2pass) + "mysql_native_password" -> let salt1 = sha1 (salt `V.append` sha1 sha1pass) in V.zipWith' xor sha1pass salt1 + "caching_sha2_password" -> let salt2 = sha2 (salt `V.append` sha2 sha2pass) in V.zipWith' xor sha2pass salt2 + _ -> throw (UnsupportedAuthPlugin plugin callStack) + sha1pass = sha1 pass + sha2pass = sha2 pass sha1 = unCEBytes . Crypto.hash Crypto.SHA160 sha2 = unCEBytes . Crypto.hash Crypto.SHA256 - -- | Send a 'COM_PING'. -- ping :: MySQLConn -> IO OK @@ -238,3 +273,6 @@ instance Exception ERRException data UnexpectedPacket = UnexpectedPacket Packet CallStack deriving (Show) instance Exception UnexpectedPacket +data UnsupportedAuthPlugin = UnsupportedAuthPlugin T.Text CallStack deriving (Show) +instance Exception UnsupportedAuthPlugin + diff --git a/Database/MySQL/Protocol/Auth.hs b/Database/MySQL/Protocol/Auth.hs index 5236120..cdc354e 100644 --- a/Database/MySQL/Protocol/Auth.hs +++ b/Database/MySQL/Protocol/Auth.hs @@ -24,8 +24,9 @@ import GHC.Generics import Z.IO.Exception import qualified Z.Data.Parser as P import qualified Z.Data.Builder as B -import qualified Z.Data.Text as T +import qualified Z.Data.Text.Base as T import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Extra as V -------------------------------------------------------------------------------- -- Authentications @@ -55,67 +56,92 @@ import qualified Z.Data.Vector as V data Greeting = Greeting { greetingProtocol :: {-# UNPACK #-} !Word8 - , greetingVersion :: {-# UNPACK #-} !V.Bytes + , greetingVersion :: {-# UNPACK #-} !T.Text , greetingConnId :: {-# UNPACK #-} !Word32 , greetingSalt1 :: {-# UNPACK #-} !V.Bytes , greetingCaps :: {-# UNPACK #-} !Word32 , greetingCharset :: {-# UNPACK #-} !Word8 , greetingStatus :: {-# UNPACK #-} !Word16 , greetingSalt2 :: {-# UNPACK #-} !V.Bytes - , greetingAuthPlugin :: {-# UNPACK #-} !V.Bytes + , greetingAuthPlugin :: {-# UNPACK #-} !T.Text } deriving (Show, Eq) decodeGreeting :: P.Parser Greeting decodeGreeting = do pv <- P.anyWord8 - sv <- decodeBytesNul - cid <- P.decodePrimLE + sv <- T.Text <$> decodeBytesNul + cid <- P.decodePrimLE @Word32 salt1 <- P.take 8 - P.skip 1 -- 0x00 + P.skipWord8 -- 0x00 capL <- P.decodePrimLE @Word16 charset <- P.anyWord8 status <- P.decodePrimLE capH <- P.decodePrimLE @Word16 let cap = fromIntegral capH `shiftL` 16 .|. fromIntegral capL authPluginLen <- P.anyWord8 -- this will issue an unused warning, see the notes below - P.skip 10 -- 10 * 0x00 + P.skip 10 -- 10 * 0x00A + salt2 <- if (cap .&. CLIENT_SECURE_CONNECTION) == 0 then pure V.empty - else decodeBytesNul -- This is different with the MySQL document here + else P.take (max 13 (fromIntegral authPluginLen - 8)) -- The doc said we should expect a MAX(13, length of auth-plugin-data - 8) - -- length bytes, but doing so stop us from login - -- anyway 'decodeBytesNul' works perfectly here. + -- length bytes, but we have to remove the trailing NULL byte, see below V.init authPlugin <- if (cap .&. CLIENT_PLUGIN_AUTH) == 0 then pure V.empty else decodeBytesNul - return (Greeting pv sv cid salt1 cap charset status salt2 authPlugin) + return (Greeting pv sv cid salt1 cap charset status (V.init salt2) (T.Text authPlugin)) -data Auth = Auth - { authCaps :: {-# UNPACK #-} !Word32 - , authMaxPacket :: {-# UNPACK #-} !Word32 - , authCharset :: {-# UNPACK #-} !Word8 - , authName :: {-# UNPACK #-} !V.Bytes - , authPassword :: {-# UNPACK #-} !V.Bytes -- ^ the auth response - , authSchema :: {-# UNPACK #-} !V.Bytes - , authPlugin :: {-# UNPACK #-} !V.Bytes +data HandshakeResponse41 = HandshakeResponse41 + { clientCaps :: {-# UNPACK #-} !Word32 + , clientMaxPacket :: {-# UNPACK #-} !Word32 + , clientCharset :: {-# UNPACK #-} !Word8 + , clientName :: {-# UNPACK #-} !T.Text + , clientPassword :: {-# UNPACK #-} !V.Bytes -- ^ the auth response + , clientSchema :: {-# UNPACK #-} !T.Text + , clientPlugin :: {-# UNPACK #-} !T.Text } deriving (Show, Eq) -encodeAuth :: Auth -> B.Builder () -encodeAuth (Auth cap m c n p s plugin) = do +encodeHandshakeResponse41 :: HandshakeResponse41 -> B.Builder () +encodeHandshakeResponse41 (HandshakeResponse41 cap m c n p s plugin) = do B.encodePrimLE cap B.encodePrimLE m B.word8 c replicateM_ 23 (B.word8 0x00) - B.bytes n >> B.word8 0x00 + B.text n >> B.word8 0x00 B.word8 $ fromIntegral (V.length p) B.bytes p - B.bytes s + B.text s B.word8 0x00 - B.bytes plugin + B.text plugin B.word8 0x00 +data AuthResponse = FastAuthSuccess | PerformFullAuthentication deriving (Show, Eq) + +isAuthResponse :: Packet -> Bool +isAuthResponse p = pLen p == 2 && V.unsafeIndex (pBody p) 0 == 0x01 + +decodeAuthResponse :: Packet -> AuthResponse +decodeAuthResponse p = if V.unsafeIndex (pBody p) 1 == 0x03 then FastAuthSuccess else PerformFullAuthentication + +data AuthSwitchRequest = AuthSwitchRequest + { authPluginName :: {-# UNPACK #-} !T.Text + , authPluginData :: {-# UNPACK #-} !V.Bytes + } deriving (Show, Eq) + +isAuthSwitchRequest :: Packet -> Bool +isAuthSwitchRequest p = V.unsafeIndex (pBody p) 0 == 0xFE + +decodeAuthSwitchRequest :: P.Parser AuthSwitchRequest +decodeAuthSwitchRequest = do + P.skipWord8 -- 0xFE + n <- decodeBytesNul + d <- P.takeRemaining + return (AuthSwitchRequest (T.Text n) (V.take 20 d)) + +newtype AuthSwitchResponse = AuthSwitchResponse V.Bytes + data SSLRequest = SSLRequest { sslReqCaps :: !Word32 , sslReqMaxPacket :: !Word32 @@ -145,6 +171,7 @@ clientCap = CLIENT_LONG_PASSWORD .|. CLIENT_MULTI_STATEMENTS .|. CLIENT_MULTI_RESULTS .|. CLIENT_SECURE_CONNECTION + .|. CLIENT_PLUGIN_AUTH clientMaxPacketSize :: Word32 clientMaxPacketSize = 0x00ffffff :: Word32 diff --git a/Database/MySQL/Protocol/ColumnDef.hs b/Database/MySQL/Protocol/ColumnDef.hs index 2ea1234..84cc1ab 100644 --- a/Database/MySQL/Protocol/ColumnDef.hs +++ b/Database/MySQL/Protocol/ColumnDef.hs @@ -21,6 +21,7 @@ import Data.Bits import qualified Z.Data.Parser as P import qualified Z.Data.Builder as B import qualified Z.Data.Vector as V +import qualified Z.Data.Text.Base as T import Database.MySQL.Protocol.Packet -------------------------------------------------------------------------------- @@ -29,11 +30,11 @@ import Database.MySQL.Protocol.Packet -- | A description of a field (column) of a table. data ColumnDef = ColumnDef { -- fieldCatalog :: !V.Bytes -- ^ const 'def' - columnDB :: {-# UNPACK #-} !V.Bytes -- ^ Database for table. - , columnTable :: {-# UNPACK #-} !V.Bytes -- ^ Table of column, if column was a field. - , columnOrigTable :: {-# UNPACK #-} !V.Bytes -- ^ Original table name, if table was an alias. - , columnName :: {-# UNPACK #-} !V.Bytes -- ^ Name of column. - , columnOrigName :: {-# UNPACK #-} !V.Bytes -- ^ Original column name, if an alias. + columnDB :: {-# UNPACK #-} !T.Text -- ^ Database for table. + , columnTable :: {-# UNPACK #-} !T.Text -- ^ Table of column, if column was a field. + , columnOrigTable :: {-# UNPACK #-} !T.Text -- ^ Original table name, if table was an alias. + , columnName :: {-# UNPACK #-} !T.Text -- ^ Name of column. + , columnOrigName :: {-# UNPACK #-} !T.Text -- ^ Original column name, if an alias. , columnCharSet :: {-# UNPACK #-} !Word16 -- ^ Character set number. , columnLength :: {-# UNPACK #-} !Word32 -- ^ Width of column (create length). , columnType :: {-# UNPACK #-} !FieldType @@ -43,30 +44,31 @@ data ColumnDef = ColumnDef decodeField :: P.Parser ColumnDef {-# INLINE decodeField #-} -decodeField = ColumnDef - <$> (P.skip 4 -- const "def" - *> decodeLenEncBytes) -- db - <*> decodeLenEncBytes -- table - <*> decodeLenEncBytes -- origTable - <*> decodeLenEncBytes -- name - <*> decodeLenEncBytes -- origName - <* P.skip 1 -- const 0x0c - <*> P.decodePrimLE -- charset - <*> P.decodePrimLE -- length - <*> P.decodePrim -- type - <*> P.decodePrimLE -- flags - <*> P.decodePrim -- decimals - <* P.skip 2 -- const 0x00 0x00 +decodeField = do + P.skip 4 -- const "def" + db <- decodeLenEncBytes + table <- decodeLenEncBytes + origTable <- decodeLenEncBytes + name <- decodeLenEncBytes + origName <- decodeLenEncBytes + P.skipWord8 -- const 0x0c + charset <- P.decodePrimLE + len <- P.decodePrimLE + typ <- P.decodePrim + flags <- P.decodePrimLE + decimals <- P.decodePrim + P.skip 2 -- const 0x00 0x00 + return (ColumnDef (T.Text db) (T.Text table) (T.Text origTable) (T.Text name) (T.Text origName) charset len typ flags decimals) encodeField :: ColumnDef -> B.Builder () {-# INLINE encodeField #-} encodeField (ColumnDef db tbl otbl name oname charset len typ flags dec) = do encodeLenEncBytes "def" - encodeLenEncBytes db - encodeLenEncBytes tbl - encodeLenEncBytes otbl - encodeLenEncBytes name - encodeLenEncBytes oname + encodeLenEncBytes (T.getUTF8Bytes db) + encodeLenEncBytes (T.getUTF8Bytes tbl) + encodeLenEncBytes (T.getUTF8Bytes otbl) + encodeLenEncBytes (T.getUTF8Bytes name) + encodeLenEncBytes (T.getUTF8Bytes oname) B.encodePrimLE charset B.encodePrimLE len B.encodePrim typ diff --git a/Database/MySQL/Protocol/MySQLValue.hs b/Database/MySQL/Protocol/MySQLValue.hs index 8d6908b..4539a8b 100644 --- a/Database/MySQL/Protocol/MySQLValue.hs +++ b/Database/MySQL/Protocol/MySQLValue.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : Database.MySQL.Protocol.MySQLValue @@ -31,7 +32,6 @@ module Database.MySQL.Protocol.MySQLValue , makeNullMap ) where -import Control.Applicative import Control.Monad import Data.Bits import Data.Fixed (Pico) @@ -44,7 +44,6 @@ import Data.Time.Format (defaultTimeLocale, import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) import Data.Word -import Data.Word import Database.MySQL.Protocol.ColumnDef import Database.MySQL.Protocol.Escape import Database.MySQL.Protocol.Packet @@ -52,6 +51,7 @@ import GHC.Generics (Generic) import qualified Z.Data.Builder as B import qualified Z.Data.Parser as P import qualified Z.Data.Text as T +import qualified Z.Data.Text.Base as T import qualified Z.Data.Vector as V import qualified Z.Data.Vector.Extra as V @@ -81,22 +81,22 @@ import qualified Z.Data.Vector.Extra as V -- precision. -- data MySQLValue - = MySQLDecimal {-# UNAPCK #-} !Scientific -- ^ DECIMAL, NEWDECIMAL - | MySQLInt8U {-# UNAPCK #-} !Word8 -- ^ Unsigned TINY - | MySQLInt8 {-# UNAPCK #-} !Int8 -- ^ TINY - | MySQLInt16U {-# UNAPCK #-} !Word16 -- ^ Unsigned SHORT - | MySQLInt16 {-# UNAPCK #-} !Int16 -- ^ SHORT - | MySQLInt32U {-# UNAPCK #-} !Word32 -- ^ Unsigned LONG, INT24 - | MySQLInt32 {-# UNAPCK #-} !Int32 -- ^ LONG, INT24 - | MySQLInt64U {-# UNAPCK #-} !Word64 -- ^ Unsigned LONGLONG - | MySQLInt64 {-# UNAPCK #-} !Int64 -- ^ LONGLONG - | MySQLFloat {-# UNAPCK #-} !Float -- ^ IEEE 754 single precision format - | MySQLDouble {-# UNAPCK #-} !Double -- ^ IEEE 754 double precision format - | MySQLYear {-# UNAPCK #-} !Word16 -- ^ YEAR - | MySQLDateTime {-# UNAPCK #-} !LocalTime -- ^ DATETIME - | MySQLTimeStamp {-# UNAPCK #-} !LocalTime -- ^ TIMESTAMP - | MySQLDate {-# UNAPCK #-} !Day -- ^ DATE - | MySQLTime {-# UNAPCK #-} !Word8 -- ^ sign(0 = non-negative, 1 = negative), the sign is OPPOSITE to binlog one !!! + = MySQLDecimal {-# UNPACK #-} !Scientific -- ^ DECIMAL, NEWDECIMAL + | MySQLInt8U {-# UNPACK #-} !Word8 -- ^ Unsigned TINY + | MySQLInt8 {-# UNPACK #-} !Int8 -- ^ TINY + | MySQLInt16U {-# UNPACK #-} !Word16 -- ^ Unsigned SHORT + | MySQLInt16 {-# UNPACK #-} !Int16 -- ^ SHORT + | MySQLInt32U {-# UNPACK #-} !Word32 -- ^ Unsigned LONG, INT24 + | MySQLInt32 {-# UNPACK #-} !Int32 -- ^ LONG, INT24 + | MySQLInt64U {-# UNPACK #-} !Word64 -- ^ Unsigned LONGLONG + | MySQLInt64 {-# UNPACK #-} !Int64 -- ^ LONGLONG + | MySQLFloat {-# UNPACK #-} !Float -- ^ IEEE 754 single precision format + | MySQLDouble {-# UNPACK #-} !Double -- ^ IEEE 754 double precision format + | MySQLYear {-# UNPACK #-} !Word16 -- ^ YEAR + | MySQLDateTime {-# UNPACK #-} !LocalTime -- ^ DATETIME + | MySQLTimeStamp {-# UNPACK #-} !LocalTime -- ^ TIMESTAMP + | MySQLDate {-# UNPACK #-} !Day -- ^ DATE + | MySQLTime {-# UNPACK #-} !Word8 -- ^ sign(0 = non-negative, 1 = negative), the sign is OPPOSITE to binlog one !!! !TimeOfDay -- ^ hh mm ss microsecond | MySQLGeometry {-# UNPACK #-} !V.Bytes -- ^ todo: parsing to something meanful | MySQLBytes {-# UNPACK #-} !V.Bytes @@ -133,6 +133,7 @@ encodeParamMySQLType MySQLNull = B.encodePrim (MySQLTypeNull , -------------------------------------------------------------------------------- -- | Text protocol decoder decodeTextField :: ColumnDef -> P.Parser MySQLValue +{-# INLINABLE decodeTextField #-} decodeTextField f | t == MySQLTypeNull = pure MySQLNull | t == MySQLTypeDecimal @@ -171,11 +172,11 @@ decodeTextField f || t == MySQLTypeLongBlob || t == MySQLTypeBlob || t == MySQLTypeVarString - || t == MySQLTypeString = (if isText then MySQLText . T.validate else MySQLBytes) <$> decodeLenEncBytes + || t == MySQLTypeString = (if isText then MySQLText . T.Text else MySQLBytes) <$> decodeLenEncBytes | t == MySQLTypeBit = MySQLBit <$> (decodeBits =<< decodeLenEncInt) - | otherwise = fail $ "Database.MySQL.Protocol.MySQLValue: missing text decoder for " ++ show t + | otherwise = P.fail' $ "Database.MySQL.Protocol.MySQLValue: missing text decoder for " <> T.toText t where t = columnType f isUnsigned = flagUnsigned (columnFlags f) @@ -187,7 +188,7 @@ feedLenEncBytes typ con p = do bs <- decodeLenEncBytes case P.parse' p bs of Right v -> return (con v) - Left e -> fail $ "Database.MySQL.Protocol.MySQLValue: parsing " ++ show typ ++ " failed, " ++ show e + Left e -> P.fail' $ T.concat ["Database.MySQL.Protocol.MySQLValue: parsing ", T.toText typ, " failed, ", T.toText e] -------------------------------------------------------------------------------- -- | Text protocol encoder @@ -332,8 +333,7 @@ decodeBinaryField f then pure (MySQLText (T.validate bs)) else pure (MySQLBytes bs) | t == MySQLTypeBit = MySQLBit <$> (decodeBits =<< decodeLenEncInt) - | otherwise = fail $ "Database.MySQL.Protocol.MySQLValue:\ - \ missing binary decoder for " ++ show t + | otherwise = P.fail' $ "Database.MySQL.Protocol.MySQLValue: missing binary decoder for " <> T.toText t where t = columnType f isUnsigned = flagUnsigned (columnFlags f) @@ -365,8 +365,8 @@ decodeBits bytes = | bytes == 6 -> fromIntegral <$> decodeWord48BE | bytes == 7 -> fromIntegral <$> decodeWord56BE | bytes == 8 -> fromIntegral <$> P.decodePrimBE @Word64 - | otherwise -> fail $ "Database.MySQL.Protocol.MySQLValue: \ - \wrong bit length size: " ++ show bytes + | otherwise -> P.fail' $ "Database.MySQL.Protocol.MySQLValue: \ + \wrong bit length size: " <> T.toText bytes {-# INLINE decodeBits #-} diff --git a/Database/MySQL/Protocol/Packet.hs b/Database/MySQL/Protocol/Packet.hs index f7049b1..8c14c4d 100644 --- a/Database/MySQL/Protocol/Packet.hs +++ b/Database/MySQL/Protocol/Packet.hs @@ -17,6 +17,8 @@ module Database.MySQL.Protocol.Packet where import Data.Bits import Data.Word +import Data.Int.Int24 +import Data.Word.Word24 import GHC.Generics import Z.IO.Exception import qualified Z.Data.Parser as P @@ -73,7 +75,7 @@ isThereMore p = okStatus p .&. 0x08 /= 0 -- here we choose stability over correctness by omit incomplete consumed case: -- if we successful parse a packet, then we don't care if there're bytes left. -- -decodeFromPacket :: P.Parser a -> Packet -> IO a +decodeFromPacket :: HasCallStack => P.Parser a -> Packet -> IO a decodeFromPacket g (Packet _ _ body) = unwrap "EPARSE" $ P.parse' g body {-# INLINE decodeFromPacket #-} @@ -140,7 +142,7 @@ decodeEOF = EOF <$ P.skip 1 -- Helpers decodeBytesNul :: P.Parser V.Bytes -decodeBytesNul = P.takeTill (== 0) +decodeBytesNul = P.takeTill (== 0) <* P.skipWord8 {-# INLINE decodeBytesNul #-} encodeLenEncBytes :: V.Bytes -> B.Builder () @@ -207,6 +209,13 @@ decodeWord24BE = do return $! b .|. (a `unsafeShiftL` 8) {-# INLINE decodeWord24BE #-} +decodeInt24BE :: P.Parser Int24 +decodeInt24BE = do + a <- fromIntegral <$> P.decodePrimBE @Word16 + b <- fromIntegral <$> P.anyWord8 + return $! fromIntegral $ (b .|. (a `unsafeShiftL` 8) :: Word24) +{-# INLINE decodeInt24BE #-} + decodeWord40BE, decodeWord48BE, decodeWord56BE :: P.Parser Word64 decodeWord40BE = do a <- fromIntegral <$> P.decodePrimBE @Word32 diff --git a/benchmark/select/MySQLHaskell.hs b/benchmark/select/MySQLHaskell.hs index 3835dab..96fb6de 100644 --- a/benchmark/select/MySQLHaskell.hs +++ b/benchmark/select/MySQLHaskell.hs @@ -6,30 +6,33 @@ module Main where import Control.Concurrent.Async import Control.Monad import Database.MySQL.Base -import System.Environment -import System.IO.Streams (fold) +import Z.Data.PrimRef +import Z.Data.CBytes as CB +import Z.IO.BIO +import Z.IO import qualified Data.ByteString as B main :: IO () main = do args <- getArgs - case args of [threadNum] -> go (read threadNum) - _ -> putStrLn "No thread number provided." + case args of (_:threadNum:_) -> go (read (CB.unpack threadNum)) + _ -> putStdLn "No thread number provided." go :: Int -> IO () go n = void . flip mapConcurrently [1..n] $ \ _ -> do - c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" + withResource (connect defaultConnectInfo { ciUser = "testMySQLHaskell" , ciDatabase = "testMySQLHaskell" - } - - (fs, is) <- query_ c "SELECT * FROM employees" - (rowCount :: Int) <- fold (\s _ -> s+1) 0 is - putStr "field name: " - forM_ fs $ \ f -> B.putStr (columnName f) >> B.putStr ", " - putStr "\n" - putStr "numbers of rows: " - print rowCount - + , ciPassword = "testMySQLHaskell123456!" + }) $ \ c -> do + + (fs, is) <- query_ c "SELECT * FROM employees" + c <- newCounter 0 + runBIO $ is . counterNode c + (rowCount :: Int) <- readPrimIORef c + putStd "field name: " + forM_ fs $ \ f -> printStd (columnName f) >> putStdLn ", " + putStd "numbers of rows: " + printStd rowCount diff --git a/benchmark/select/MySQLHaskellPrepared.hs b/benchmark/select/MySQLHaskellPrepared.hs index 04f5395..cd4c393 100644 --- a/benchmark/select/MySQLHaskellPrepared.hs +++ b/benchmark/select/MySQLHaskellPrepared.hs @@ -6,31 +6,34 @@ module Main where import Control.Concurrent.Async import Control.Monad import Database.MySQL.Base -import System.Environment -import System.IO.Streams (fold) +import Z.Data.CBytes as CB +import Z.Data.PrimRef +import Z.IO.BIO +import Z.IO import qualified Data.ByteString as B main :: IO () main = do args <- getArgs - case args of [threadNum] -> go (read threadNum) - _ -> putStrLn "No thread number provided." + case args of (_:threadNum:_) -> go (read (CB.unpack threadNum)) + _ -> putStdLn "No thread number provided." go :: Int -> IO () go n = void . flip mapConcurrently [1..n] $ \ _ -> do - c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" + withResource (connect defaultConnectInfo { ciUser = "testMySQLHaskell" , ciDatabase = "testMySQLHaskell" - } - - - stmt <- prepareStmt c "SELECT * FROM employees" - (fs, is) <- queryStmt c stmt [] - (rowCount :: Int) <- fold (\s _ -> s+1) 0 is - putStr "field name: " - forM_ fs $ \ f -> B.putStr (columnName f) >> B.putStr ", " - putStr "\n" - putStr "numbers of rows: " - print rowCount + , ciPassword = "testMySQLHaskell123456!" + }) $ \ c -> do + + stmt <- prepareStmt c "SELECT * FROM employees" + (fs, is) <- queryStmt c stmt [] + c <- newCounter 0 + runBIO $ is . counterNode c + (rowCount :: Int) <- readPrimIORef c + putStd "field name: " + forM_ fs $ \ f -> printStd (columnName f) >> putStdLn ", " + putStd "numbers of rows: " + printStd rowCount diff --git a/benchmark/select/MySQLHaskellTLS.hs b/benchmark/select/MySQLHaskellTLS.hs index 4b4e75a..cf1e48a 100644 --- a/benchmark/select/MySQLHaskellTLS.hs +++ b/benchmark/select/MySQLHaskellTLS.hs @@ -24,6 +24,7 @@ go n = do void . flip mapConcurrently [1..n] $ \ _ -> do c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" , ciDatabase = "testMySQLHaskell" + , ciPassword = "testMySQLHaskell123456!" } (cparams, "MySQL") diff --git a/benchmark/select/libmysql.cpp b/benchmark/select/libmysql.cpp index 86ccb15..844e985 100644 --- a/benchmark/select/libmysql.cpp +++ b/benchmark/select/libmysql.cpp @@ -8,7 +8,7 @@ #define THREAD_NUM 4 #define DBHOST "127.0.0.1" #define DBUSER "testMySQLHaskell" -#define DBPASS "" +#define DBPASS "testMySQLHaskell123456!" #define DBPORT 3306 #define DBNAME "testMySQLHaskell" #define DBSOCK NULL //"/var/lib/mysql/mysql.sock" diff --git a/benchmark/select/mysql-haskell-bench.cabal b/benchmark/select/mysql-haskell-bench.cabal index a67f9e8..5c0b296 100644 --- a/benchmark/select/mysql-haskell-bench.cabal +++ b/benchmark/select/mysql-haskell-bench.cabal @@ -18,15 +18,12 @@ cabal-version: >=1.10 library hs-source-dirs: ../../ exposed-modules: Database.MySQL.Base - , Database.MySQL.TLS - , Database.MySQL.OpenSSL , Database.MySQL.Protocol.Auth , Database.MySQL.Protocol.Command , Database.MySQL.Protocol.ColumnDef , Database.MySQL.Protocol.Packet , Database.MySQL.Protocol.MySQLValue , Database.MySQL.Protocol.Escape - , Database.MySQL.BinLog , Database.MySQL.BinLogProtocol.BinLogEvent , Database.MySQL.BinLogProtocol.BinLogValue , Database.MySQL.BinLogProtocol.BinLogMeta @@ -34,33 +31,23 @@ library other-modules: Database.MySQL.Connection , Database.MySQL.Query - build-depends: base >=4.7 && <5 + build-depends: base >= 4.7 && < 5 , monad-loops == 0.4.* - , network >= 2.3 && < 3.0 - , io-streams >= 1.2 && < 2.0 - , tcp-streams == 0.5.* - , wire-streams >= 0.1 - , binary == 0.8.* - , binary-ieee754 == 0.1.* - , binary-parsers >= 0.2.1 - , bytestring >= 0.10.2.0 - , text >= 1.1 && < 1.3 - , cryptonite == 0.* - , memory >= 0.8 , time >= 1.5.0 , scientific == 0.3.* - , bytestring-lexing == 0.5.* - , blaze-textual == 0.2.* - , word24 == 1.* - , tls >=1.3.5 && < 1.4 - , HsOpenSSL >=0.10.3 && <0.12 - , vector >= 0.8 + , Z-Data >= 0.8.8 && < 0.9 + , Z-IO >= 0.8.1 && < 0.9 + , Z-Botan >= 0.4 && < 0.5 + , word24 default-language: Haskell2010 default-extensions: DeriveDataTypeable , DeriveGeneric + , DeriveAnyClass + , DerivingStrategies , MultiWayIf , OverloadedStrings + , TypeApplications if os(mingw32) || os(windows) extra-libraries: eay32, ssl32 @@ -71,38 +58,39 @@ library include-dirs: /usr/local/opt/openssl/include else extra-libraries: crypto + c-sources: ../../cbits/escape.c executable bench - build-depends: base, mysql-haskell-bench, bytestring, io-streams, async + build-depends: base, mysql-haskell-bench, bytestring, Z-Data, Z-IO, async default-language: Haskell2010 hs-source-dirs: . main-is: MySQLHaskell.hs ghc-options: -O2 -threaded -rtsopts -executable bench-tls - build-depends: base, mysql-haskell-bench, bytestring, io-streams, async, tcp-streams - default-language: Haskell2010 - hs-source-dirs: . - main-is: MySQLHaskellTLS.hs - ghc-options: -O2 -threaded -rtsopts - -executable bench-openssl - build-depends: base, mysql-haskell-bench, bytestring, io-streams, async, tcp-streams - default-language: Haskell2010 - hs-source-dirs: . - main-is: MySQLHaskellOpenSSL.hs - ghc-options: -O2 -threaded -rtsopts +-- executable bench-tls +-- build-depends: base, mysql-haskell-bench, bytestring, io-streams, async, tcp-streams +-- default-language: Haskell2010 +-- hs-source-dirs: . +-- main-is: MySQLHaskellTLS.hs +-- ghc-options: -O2 -threaded -rtsopts +-- +-- executable bench-openssl +-- build-depends: base, mysql-haskell-bench, bytestring, io-streams, async, tcp-streams +-- default-language: Haskell2010 +-- hs-source-dirs: . +-- main-is: MySQLHaskellOpenSSL.hs +-- ghc-options: -O2 -threaded -rtsopts executable benchPrepared - build-depends: base, mysql-haskell-bench, bytestring, io-streams, async + build-depends: base, mysql-haskell-bench, bytestring, Z-Data, Z-IO, async default-language: Haskell2010 hs-source-dirs: . main-is: MySQLHaskellPrepared.hs ghc-options: -O2 -threaded -rtsopts -executable benchFFI - build-depends: base, async, mysql, text, mysql-simple, time - default-language: Haskell2010 - hs-source-dirs: . - main-is: MySQLFFI.hs - ghc-options: -O2 -threaded -rtsopts +-- executable benchFFI +-- build-depends: base, async, mysql, text, mysql-simple, time +-- default-language: Haskell2010 +-- hs-source-dirs: . +-- main-is: MySQLFFI.hs +-- ghc-options: -O2 -threaded -rtsopts diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal index d44fbed..329ecdb 100644 --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -29,16 +29,17 @@ library Database.MySQL.Base --, Database.MySQL.TLS - --, Database.MySQL.BinLog - --, Database.MySQL.BinLogProtocol.BinLogEvent - --, Database.MySQL.BinLogProtocol.BinLogValue - --, Database.MySQL.BinLogProtocol.BinLogMeta + -- Database.MySQL.BinLog + Database.MySQL.BinLogProtocol.BinLogEvent + Database.MySQL.BinLogProtocol.BinLogValue + Database.MySQL.BinLogProtocol.BinLogMeta other-modules: -- Database.MySQL.Query build-depends: base >= 4.7 && < 5 , monad-loops == 0.4.* , time >= 1.5.0 , scientific == 0.3.* + , word24 >= 2.0 && < 3.0 , Z-Data >= 0.8.8 && < 0.9 , Z-IO >= 0.8.1 && < 0.9 , Z-Botan >= 0.4 && < 0.5 From f31af81360f1e40c47fec5e4c986271e4abf6512 Mon Sep 17 00:00:00 2001 From: Dong Han Date: Tue, 13 Jul 2021 15:26:20 +0800 Subject: [PATCH 4/4] W.I.P --- Database/MySQL/Base.hs | 9 +- Database/MySQL/BinLog.hs | 16 +- Database/MySQL/BinLogProtocol/BinLogEvent.hs | 2 +- Database/MySQL/Connection.hs | 62 ++++---- Database/MySQL/Protocol/Auth.hs | 2 +- Database/MySQL/Protocol/ColumnDef.hs | 30 ++-- Database/MySQL/Protocol/MySQLValue.hs | 89 ++++++----- Database/MySQL/Protocol/Packet.hs | 18 ++- benchmark/insert/MySQLHaskell.hs | 87 ++++++----- benchmark/insert/MySQLHaskellInsertMany.hs | 88 ++++++----- benchmark/insert/MySQLHaskellPrepared.hs | 149 ++++++++++--------- benchmark/insert/insert.sql | 43 ++++-- benchmark/insert/libmysql.cpp | 2 +- benchmark/insert/mysql-haskell-bench.cabal | 39 ++--- benchmark/select/MySQLHaskell.hs | 27 ++-- benchmark/select/MySQLHaskellPrepared.hs | 28 ++-- benchmark/select/libmysql_prepared.cpp | 6 +- benchmark/select/mysql-haskell-bench.cabal | 10 +- mysql-haskell.cabal | 7 +- 19 files changed, 395 insertions(+), 319 deletions(-) diff --git a/Database/MySQL/Base.hs b/Database/MySQL/Base.hs index 2e74a59..6d7b8ee 100644 --- a/Database/MySQL/Base.hs +++ b/Database/MySQL/Base.hs @@ -80,6 +80,7 @@ import Z.Data.ASCII import qualified Z.Data.Vector as V import qualified Z.Data.Text as T import Z.IO +import Z.IO.BIO (Source, sourceFromIO) -------------------------------------------------------------------------------- @@ -139,8 +140,7 @@ query conn qry params = query_ conn (renderParams qry params) readFields :: HasCallStack => Int -> BufferedInput -> IO (V.Vector ColumnDef) {-# INLINABLE readFields #-} -readFields len is = - V.replicateMVec len (decodeFromPacket decodeField =<< readPacket is) +readFields len is = V.replicateM len (decodeFromPacket decodeField =<< readPacket is) -- | Execute a MySQL query which return a result-set. -- @@ -157,7 +157,7 @@ query_ conn@(MySQLConn is os consumed) (Query qry) = do q <- readPacket is if isEOF q then writeIORef consumed True >> return Nothing - else Just <$> decodeFromPacket (decodeTextRow fields) q + else Just <$!> decodeFromPacket (decodeTextRow fields) q return (fields, rows) -- | Ask MySQL to prepare a query statement. @@ -217,6 +217,7 @@ executeStmt conn stid params = -- queryStmt :: HasCallStack => MySQLConn -> StmtID -> [MySQLValue] -> IO (V.Vector ColumnDef, Source (V.Vector MySQLValue)) +{-# INLINABLE queryStmt #-} queryStmt conn@(MySQLConn is os consumed) stid params = do guardUnconsumed conn writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os @@ -227,7 +228,7 @@ queryStmt conn@(MySQLConn is os consumed) stid params = do writeIORef consumed False let rows = sourceFromIO $ do q <- readPacket is - if | isOK q -> Just <$> decodeFromPacket (decodeBinaryRow fields len) q + if | isOK q -> Just <$!> decodeFromPacket (decodeBinaryRow fields len) q | isEOF q -> writeIORef consumed True >> return Nothing | otherwise -> throwIO (UnexpectedPacket q callStack) return (fields, rows) diff --git a/Database/MySQL/BinLog.hs b/Database/MySQL/BinLog.hs index 723bed4..e209d27 100644 --- a/Database/MySQL/BinLog.hs +++ b/Database/MySQL/BinLog.hs @@ -29,7 +29,6 @@ module Database.MySQL.BinLog ) where import Control.Applicative -import Z.IO.Exception import Control.Monad import Data.IORef import Data.Word @@ -38,7 +37,10 @@ import Database.MySQL.BinLogProtocol.BinLogEvent import Database.MySQL.BinLogProtocol.BinLogMeta import Database.MySQL.BinLogProtocol.BinLogValue import Database.MySQL.Connection -import GHC.Generics (Generic) +import GHC.Generics (Generic) +import qualified Z.Data.Vector as V +import Z.IO.Exception +import qualified Z.IO.BIO as BIO type SlaveID = Word32 @@ -63,7 +65,7 @@ dumpBinLog :: MySQLConn -- ^ connection to be listened -> BinLogTracker -- ^ binlog position -> Bool -- ^ if master support semi-ack, do we want to enable it? -- if master doesn't support, this parameter will be ignored. - -> IO (FormatDescription, IORef ByteString, Source BinLogPacket) + -> IO (FormatDescription, IORef V.Bytes, BIO.Source BinLogPacket) -- ^ 'FormatDescription', 'IORef' contains current binlog filename, 'BinLogPacket' stream. dumpBinLog conn@(MySQLConn is wp _ consumed) sid (BinLogTracker initfn initpos) wantAck = do guardUnconsumed conn @@ -77,7 +79,7 @@ dumpBinLog conn@(MySQLConn is wp _ consumed) sid (BinLogTracker initfn initpos) rp <- skipToPacketT (readBinLogPacket checksum needAck is) BINLOG_ROTATE_EVENT re <- getFromBinLogPacket getRotateEvent rp - fref <- newIORef (rFileName re) + fref <- newTVarIO (rFileName re) p <- skipToPacketT (readBinLogPacket checksum needAck is) BINLOG_FORMAT_DESCRIPTION_EVENT replyAck needAck p fref wp @@ -112,7 +114,7 @@ dumpBinLog conn@(MySQLConn is wp _ consumed) sid (BinLogTracker initfn initpos) readBinLogPacket checksum needAck is' = do p <- readPacket is' - if | isOK p -> Just <$> getFromPacket (getBinLogPacket checksum needAck) p + if | isOK p -> Just <$!> getFromPacket (getBinLogPacket checksum needAck) p | isEOF p -> return Nothing | isERR p -> decodeFromPacket p >>= throwIO . ERRException @@ -135,8 +137,8 @@ data RowBinLogEvent deriving (Show, Eq, Generic) -- | decode row based event from 'BinLogPacket' stream. -decodeRowBinLogEvent :: (FormatDescription, IORef ByteString, InputStream BinLogPacket) - -> IO (InputStream RowBinLogEvent) +decodeRowBinLogEvent :: (FormatDescription, IORef V.Bytes, BIO.Source BinLogPacket) + -> IO (Source RowBinLogEvent) decodeRowBinLogEvent (fd', fref', is') = Stream.makeInputStream (loop fd' fref' is') where loop fd fref is = do diff --git a/Database/MySQL/BinLogProtocol/BinLogEvent.hs b/Database/MySQL/BinLogProtocol/BinLogEvent.hs index 24f1604..7e59774 100644 --- a/Database/MySQL/BinLogProtocol/BinLogEvent.hs +++ b/Database/MySQL/BinLogProtocol/BinLogEvent.hs @@ -196,7 +196,7 @@ decodeTableMapEvent fd = do typs <- P.take cc colMetaBS <- decodeLenEncBytes - metas <- case P.parse' (V.traverseVec decodeBinLogMeta typs) colMetaBS of + metas <- case P.parse' (V.traverse decodeBinLogMeta typs) colMetaBS of Left errmsg -> P.fail' (T.concat errmsg) Right r -> return r diff --git a/Database/MySQL/Connection.hs b/Database/MySQL/Connection.hs index 2ecefb3..7247ca6 100644 --- a/Database/MySQL/Connection.hs +++ b/Database/MySQL/Connection.hs @@ -73,7 +73,7 @@ data ConnectInfo = ConnectInfo defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnectInfo (Right defaultTCPClientConfig{ tcpRemoteAddr = SocketAddrIPv4 ipv4Loopback 3306 }) - defaultChunkSize defaultChunkSize + V.defaultChunkSize V.defaultChunkSize "" "root" "" utf8_general_ci Nothing -- | 'defaultConnectInfo' with charset set to @utf8mb4_unicode_ci@ @@ -83,7 +83,7 @@ defaultConnectInfo = ConnectInfo defaultConnectInfoMB4 :: ConnectInfo defaultConnectInfoMB4 = ConnectInfo (Right defaultTCPClientConfig{ tcpRemoteAddr = SocketAddrIPv4 ipv4Loopback 3306 }) - defaultChunkSize defaultChunkSize + V.defaultChunkSize V.defaultChunkSize "" "root" "" utf8mb4_unicode_ci Nothing utf8_general_ci :: Word8 @@ -94,13 +94,6 @@ utf8mb4_unicode_ci = 224 -------------------------------------------------------------------------------- --- | Socket buffer size. --- --- maybe exposed to 'ConnectInfo' laster? --- -bUFSIZE :: Int -bUFSIZE = 16384 - -- | Establish a MySQL connection. -- connect :: ConnectInfo -> Resource MySQLConn @@ -114,8 +107,7 @@ connectDetail (ConnectInfo conf recvBufSiz sendBufSiz db user (T.getUTF8Bytes -> initResource (do (bi, bo) <- newBufferedIO' uvs recvBufSiz sendBufSiz greet <- decodeFromPacket decodeGreeting =<< readPacket bi - writeBuilder bo $ encodePacket (encodeToPacket 1 (encodeHandshakeResponse41 (mkAuth41 greet))) - flushBuffer bo + writePacket bo (encodeToPacket 1 (encodeHandshakeResponse41 (mkAuth41 greet))) handleAuthRes greet bi bo consumed <- newIORef True return (greet, MySQLConn bi bo consumed)) @@ -139,8 +131,7 @@ connectDetail (ConnectInfo conf recvBufSiz sendBufSiz db user (T.getUTF8Bytes -> -- TODO, update greet packet? (AuthSwitchRequest plugin salt) <- decodeFromPacket decodeAuthSwitchRequest authRes let scambleBuf = scramble plugin salt - writeBuilder bo $ encodePacket (Packet (V.length scambleBuf) 3 scambleBuf) - flushBuffer bo + writePacket bo (Packet (V.length scambleBuf) 3 scambleBuf) handleAuthRes greet bi bo when (isAuthResponse authRes) $ do @@ -152,16 +143,14 @@ connectDetail (ConnectInfo conf recvBufSiz sendBufSiz db user (T.getUTF8Bytes -> decodePubKey = do P.skipWord8 -- 0x01 P.takeRemaining - writeBuilder bo $ encodePacket pubkeyRequest - flushBuffer bo + writePacket bo pubkeyRequest loadPubKey =<< decodeFromPacket decodePubKey =<< readPacket bi) return mpubkey rng <- getRNG let salt = greetingSalt1 greet `V.append` greetingSalt2 greet encryptedPass <- if V.null pass then return V.empty else pkEncrypt pubkey (EME_OAEP SHA160 "") rng (V.zipWith' xor (pass `V.snoc` 0) salt) - writeBuilder bo $ encodePacket (Packet 256 5 encryptedPass) - flushBuffer bo + writePacket bo (Packet 256 5 encryptedPass) _ -> return () handleAuthRes greet bi bo @@ -221,19 +210,36 @@ waitCommandReplys is = do -- This function will raise 'ERRException' if 'ERR' packet is met. readPacket :: HasCallStack => BufferedInput -> IO Packet readPacket bi = do - bs <- readExactly 4 bi - let len = fromIntegral (bs `V.unsafeIndex` 0) - .|. fromIntegral (bs `V.unsafeIndex` 1) `unsafeShiftL` 8 - .|. fromIntegral (bs `V.unsafeIndex` 2) `unsafeShiftL` 16 - seqN = bs `V.unsafeIndex` 3 - body <- readExactly len bi - let p = Packet len seqN body - when (isERR p) $ do - err <- decodeFromPacket decodeERR p - throwIO (ERRException err callStack) - return p + p@(Packet l _ body) <- packet + if l < 16777215 + then pure p + else loopRead l [body] + where + loopRead !l acc = do + (Packet l' seqN body) <- packet + if l' < 16777215 + then pure (Packet (l + l') seqN (V.concat . reverse $ body:acc)) + else loopRead (l + l') (body:acc) + packet = do + bs <- readExactly 4 bi + let !len = fromIntegral (bs `V.unsafeIndex` 0) + .|. fromIntegral (bs `V.unsafeIndex` 1) `unsafeShiftL` 8 + .|. fromIntegral (bs `V.unsafeIndex` 2) `unsafeShiftL` 16 + !seqN = bs `V.unsafeIndex` 3 + body <- readExactly len bi + let p = Packet len seqN body + if (isERR p) + then do + err <- decodeFromPacket decodeERR p + throwIO (ERRException err callStack) + else pure p {-# INLINE readPacket #-} +writePacket :: HasCallStack => BufferedOutput -> Packet -> IO () +writePacket bo p = do + writeBuilder bo (encodePacket p) + flushBuffer bo + writeCommand :: Command -> BufferedOutput -> IO () writeCommand a bo = do let bs = B.buildWith V.smallChunkSize (encodeCommand a) diff --git a/Database/MySQL/Protocol/Auth.hs b/Database/MySQL/Protocol/Auth.hs index cdc354e..3bfff2c 100644 --- a/Database/MySQL/Protocol/Auth.hs +++ b/Database/MySQL/Protocol/Auth.hs @@ -78,7 +78,7 @@ decodeGreeting = do status <- P.decodePrimLE capH <- P.decodePrimLE @Word16 let cap = fromIntegral capH `shiftL` 16 .|. fromIntegral capL - authPluginLen <- P.anyWord8 -- this will issue an unused warning, see the notes below + authPluginLen <- P.anyWord8 P.skip 10 -- 10 * 0x00A salt2 <- if (cap .&. CLIENT_SECURE_CONNECTION) == 0 diff --git a/Database/MySQL/Protocol/ColumnDef.hs b/Database/MySQL/Protocol/ColumnDef.hs index 84cc1ab..fdf687b 100644 --- a/Database/MySQL/Protocol/ColumnDef.hs +++ b/Database/MySQL/Protocol/ColumnDef.hs @@ -44,21 +44,21 @@ data ColumnDef = ColumnDef decodeField :: P.Parser ColumnDef {-# INLINE decodeField #-} -decodeField = do - P.skip 4 -- const "def" - db <- decodeLenEncBytes - table <- decodeLenEncBytes - origTable <- decodeLenEncBytes - name <- decodeLenEncBytes - origName <- decodeLenEncBytes - P.skipWord8 -- const 0x0c - charset <- P.decodePrimLE - len <- P.decodePrimLE - typ <- P.decodePrim - flags <- P.decodePrimLE - decimals <- P.decodePrim - P.skip 2 -- const 0x00 0x00 - return (ColumnDef (T.Text db) (T.Text table) (T.Text origTable) (T.Text name) (T.Text origName) charset len typ flags decimals) +decodeField = ColumnDef + <$> (P.skip 4 -- const "def" + *> decodeLenEncText) -- db + <*> decodeLenEncText -- table + <*> decodeLenEncText -- origTable + <*> decodeLenEncText -- name + <*> decodeLenEncText -- origName + <* P.skip 1 -- const 0x0c + <*> P.decodeWord16LE -- charset + <*> P.decodeWord32LE -- length + <*> P.decodeWord8 -- type + <*> P.decodeWord16LE -- flags + <*> P.decodeWord8 -- decimals + <* P.skip 2 -- const 0x00 0x00 + encodeField :: ColumnDef -> B.Builder () {-# INLINE encodeField #-} diff --git a/Database/MySQL/Protocol/MySQLValue.hs b/Database/MySQL/Protocol/MySQLValue.hs index 4539a8b..5c32eec 100644 --- a/Database/MySQL/Protocol/MySQLValue.hs +++ b/Database/MySQL/Protocol/MySQLValue.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} {-| Module : Database.MySQL.Protocol.MySQLValue @@ -33,6 +35,7 @@ module Database.MySQL.Protocol.MySQLValue ) where import Control.Monad +import Control.DeepSeq import Data.Bits import Data.Fixed (Pico) import Data.Int @@ -50,10 +53,12 @@ import Database.MySQL.Protocol.Packet import GHC.Generics (Generic) import qualified Z.Data.Builder as B import qualified Z.Data.Parser as P +import qualified Z.Data.Parser.Time as P import qualified Z.Data.Text as T import qualified Z.Data.Text.Base as T import qualified Z.Data.Vector as V import qualified Z.Data.Vector.Extra as V +import Z.IO -------------------------------------------------------------------------------- -- | Data type mapping between MySQL values and haskell values. @@ -95,15 +100,15 @@ data MySQLValue | MySQLYear {-# UNPACK #-} !Word16 -- ^ YEAR | MySQLDateTime {-# UNPACK #-} !LocalTime -- ^ DATETIME | MySQLTimeStamp {-# UNPACK #-} !LocalTime -- ^ TIMESTAMP - | MySQLDate {-# UNPACK #-} !Day -- ^ DATE + | MySQLDate !Day -- ^ DATE | MySQLTime {-# UNPACK #-} !Word8 -- ^ sign(0 = non-negative, 1 = negative), the sign is OPPOSITE to binlog one !!! - !TimeOfDay -- ^ hh mm ss microsecond + {-# UNPACK #-} !TimeOfDay -- ^ hh mm ss microsecond | MySQLGeometry {-# UNPACK #-} !V.Bytes -- ^ todo: parsing to something meanful | MySQLBytes {-# UNPACK #-} !V.Bytes | MySQLBit {-# UNPACK #-} !Word64 | MySQLText {-# UNPACK #-} !T.Text | MySQLNull - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, NFData) -- | Put 'FieldType' and usigned bit(0x80/0x00) for 'MySQLValue's. -- @@ -133,7 +138,7 @@ encodeParamMySQLType MySQLNull = B.encodePrim (MySQLTypeNull , -------------------------------------------------------------------------------- -- | Text protocol decoder decodeTextField :: ColumnDef -> P.Parser MySQLValue -{-# INLINABLE decodeTextField #-} +{-# INLINE decodeTextField #-} decodeTextField f | t == MySQLTypeNull = pure MySQLNull | t == MySQLTypeDecimal @@ -151,9 +156,9 @@ decodeTextField f | t == MySQLTypeDouble = feedLenEncBytes t MySQLDouble P.double' | t == MySQLTypeYear = feedLenEncBytes t MySQLYear P.int | t == MySQLTypeTimestamp - || t == MySQLTypeTimestamp2 = feedLenEncBytes t MySQLTimeStamp $ P.localTime + || t == MySQLTypeTimestamp2 = feedLenEncBytes t MySQLTimeStamp P.localTime | t == MySQLTypeDateTime - || t == MySQLTypeDateTime2 = feedLenEncBytes t MySQLDateTime $ P.localTime + || t == MySQLTypeDateTime2 = feedLenEncBytes t MySQLDateTime P.localTime | t == MySQLTypeDate || t == MySQLTypeNewDate = feedLenEncBytes t MySQLDate P.day | t == MySQLTypeTime @@ -172,7 +177,10 @@ decodeTextField f || t == MySQLTypeLongBlob || t == MySQLTypeBlob || t == MySQLTypeVarString - || t == MySQLTypeString = (if isText then MySQLText . T.Text else MySQLBytes) <$> decodeLenEncBytes + || t == MySQLTypeString = do bs <- decodeLenEncBytes + if isText + then pure (MySQLText (T.validate bs)) + else pure (MySQLBytes bs) | t == MySQLTypeBit = MySQLBit <$> (decodeBits =<< decodeLenEncInt) @@ -231,16 +239,17 @@ encodeTextField MySQLNull = "NULL" -- | Text row decoder decodeTextRow :: V.Vector ColumnDef -> P.Parser (V.Vector MySQLValue) -decodeTextRow fs = (`V.traverseVec` fs) $ \ f -> do +{-# INLINABLE decodeTextRow #-} +decodeTextRow fs = (`V.traverse` fs) $ \ f -> do p <- P.peek if p == 0xFB then P.skipWord8 >> return MySQLNull else decodeTextField f -{-# INLINE decodeTextRow #-} -------------------------------------------------------------------------------- -- | Binary protocol decoder decodeBinaryField :: ColumnDef -> P.Parser MySQLValue +{-# INLINE decodeBinaryField #-} decodeBinaryField f | t == MySQLTypeNull = pure MySQLNull | t == MySQLTypeDecimal @@ -263,42 +272,42 @@ decodeBinaryField f case n of 0 -> pure $ MySQLTimeStamp (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0)) 4 -> do - d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 + d <- decodeDay pure $ MySQLTimeStamp (LocalTime d (TimeOfDay 0 0 0)) 7 -> do - d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 - td <- TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond4 + d <- decodeDay + td <- decodeTimeOfDay pure $ MySQLTimeStamp (LocalTime d td) 11 -> do - d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 - td <- TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond8 + d <- decodeDay + td <- decodeTimeOfDay' pure $ MySQLTimeStamp (LocalTime d td) - _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong TIMESTAMP length" + _ -> P.fail' "Database.MySQL.Protocol.MySQLValue: wrong TIMESTAMP length" | t == MySQLTypeDateTime || t == MySQLTypeDateTime2 = do n <- decodeLenEncInt case n of 0 -> pure $ MySQLDateTime (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0)) 4 -> do - d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 + d <- decodeDay pure $ MySQLDateTime (LocalTime d (TimeOfDay 0 0 0)) 7 -> do - d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 - td <- TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond4 + d <- decodeDay + td <- decodeTimeOfDay pure $ MySQLDateTime (LocalTime d td) 11 -> do - d <- fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8 - td <- TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond8 + d <- decodeDay + td <- decodeTimeOfDay' pure $ MySQLDateTime (LocalTime d td) - _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATETIME length" + _ -> P.fail' "Database.MySQL.Protocol.MySQLValue: wrong DATETIME length" | t == MySQLTypeDate || t == MySQLTypeNewDate = do n <- decodeLenEncInt case n of 0 -> pure $ MySQLDate (fromGregorian 0 0 0) - 4 -> MySQLDate <$> (fromGregorian <$> decodeYear <*> decodeInt8 <*> decodeInt8) - _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATE length" + 4 -> MySQLDate <$> decodeDay + _ -> P.fail' "Database.MySQL.Protocol.MySQLValue: wrong DATE length" | t == MySQLTypeTime || t == MySQLTypeTime2 = do @@ -316,7 +325,7 @@ decodeBinaryField f d <- fromIntegral <$> P.decodePrimLE @Word32 h <- decodeInt8 MySQLTime sign <$> (TimeOfDay (d*24 + h) <$> decodeInt8 <*> decodeSecond8) - _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong TIME length" + _ -> P.fail' "Database.MySQL.Protocol.MySQLValue: wrong TIME length" | t == MySQLTypeGeometry = MySQLGeometry <$> decodeLenEncBytes | t == MySQLTypeVarChar @@ -330,16 +339,28 @@ decodeBinaryField f || t == MySQLTypeString = do bs <- decodeLenEncBytes if isText - then pure (MySQLText (T.validate bs)) - else pure (MySQLBytes bs) + then pure (MySQLText (T.validate bs)) + else pure (MySQLBytes bs) | t == MySQLTypeBit = MySQLBit <$> (decodeBits =<< decodeLenEncInt) - | otherwise = P.fail' $ "Database.MySQL.Protocol.MySQLValue: missing binary decoder for " <> T.toText t + | otherwise = P.fail' $ "Database.MySQL.Protocol.MySQLValue: missing binary decoder for type tag: " <> T.toText t where t = columnType f isUnsigned = flagUnsigned (columnFlags f) isText = columnCharSet f /= 63 - decodeYear :: P.Parser Integer - decodeYear = fromIntegral <$> P.decodePrimLE @Word16 + decodeDay :: P.Parser Day + decodeDay = do + y <- decodeYear + m <- decodeInt8 + d <- decodeInt8 + case P.fromGregorianValidInt64 y m d of + Just d -> pure d + _ -> P.fail' $ T.concat ["Database.MySQL.Protocol.MySQLValue: invalid date: ", T.toText y, "-", T.toText m, "-", T.toText d] + decodeTimeOfDay :: P.Parser TimeOfDay + decodeTimeOfDay = TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond4 + decodeTimeOfDay' :: P.Parser TimeOfDay + decodeTimeOfDay' = TimeOfDay <$> decodeInt8 <*> decodeInt8 <*> decodeSecond8 + decodeYear :: P.Parser Int64 + decodeYear = fromIntegral <$> P.decodeWord16LE decodeInt8 :: P.Parser Int decodeInt8 = fromIntegral <$> P.anyWord8 decodeSecond4 :: P.Parser Pico @@ -443,11 +464,11 @@ encodeBinaryTime (TimeOfDay hh mm ss) = do decodeBinaryRow :: V.Vector ColumnDef -> Int -> P.Parser (V.Vector MySQLValue) decodeBinaryRow fields flen = do P.skipWord8 -- 0x00 - let maplen = (flen + 7 + 2) `shiftR` 3 - nullmap <- BitMap <$> P.take maplen - (`V.traverseWithIndex` fields) $ \ pos f -> + let !maplen = (flen + 7 + 2) `unsafeShiftR` 3 + !nullmap <- BitMap <$> P.take maplen + (`V.traverseWithIndex` fields) $ \ !pos !f -> if isColumnNull nullmap pos then return MySQLNull else decodeBinaryField f -{-# INLINE decodeBinaryRow #-} +{-# INLINABLE decodeBinaryRow #-} -------------------------------------------------------------------------------- -- | Use 'ByteString' to present a bitmap. @@ -465,7 +486,7 @@ decodeBinaryRow fields flen = do -- -- We don't use 'Int64' here because there maybe more than 64 columns. -- -newtype BitMap = BitMap { fromBitMap :: V.Bytes } deriving (Eq, Show) +newtype BitMap = BitMap { fromBitMap :: V.Bytes } deriving (Eq, Show, Generic, T.Print) -- | Test if a column is set(binlog protocol). -- diff --git a/Database/MySQL/Protocol/Packet.hs b/Database/MySQL/Protocol/Packet.hs index 8c14c4d..63014ea 100644 --- a/Database/MySQL/Protocol/Packet.hs +++ b/Database/MySQL/Protocol/Packet.hs @@ -15,6 +15,7 @@ MySQL packet decoder&encoder, and varities utility. module Database.MySQL.Protocol.Packet where +import Control.Monad import Data.Bits import Data.Word import Data.Int.Int24 @@ -24,6 +25,7 @@ import Z.IO.Exception import qualified Z.Data.Parser as P import qualified Z.Data.Builder as B import qualified Z.Data.Text as T +import qualified Z.Data.Text.Base as T import qualified Z.Data.Vector as V import qualified Z.Data.Vector.Extra as V @@ -155,17 +157,21 @@ decodeLenEncBytes :: P.Parser V.Bytes decodeLenEncBytes = decodeLenEncInt >>= P.take {-# INLINE decodeLenEncBytes #-} +decodeLenEncText :: P.Parser T.Text +decodeLenEncText = T.validate <$!> decodeLenEncBytes +{-# INLINE decodeLenEncText #-} + -- | length encoded int -- https://dev.mysql.com/doc/internals/en/integer.html#packet-Protocol::LengthEncodedInteger decodeLenEncInt:: P.Parser Int decodeLenEncInt = P.anyWord8 >>= word2Len where word2Len l - | l < 0xFB = pure (fromIntegral l) - | l == 0xFC = fromIntegral <$> P.decodePrimLE @Word16 - | l == 0xFD = fromIntegral <$> decodeWord24LE - | l == 0xFE = fromIntegral <$> P.decodePrimLE @Word64 - | otherwise = fail $ "invalid length val " ++ show l + | l < 0xFB = pure $! fromIntegral l + | l == 0xFC = fromIntegral <$!> P.decodeWord16LE + | l == 0xFD = fromIntegral <$!> decodeWord24LE + | l == 0xFE = fromIntegral <$!> P.decodeWord64LE + | otherwise = P.fail' $ "invalid length val: " <> T.toText l {-# INLINE decodeLenEncInt #-} encodeLenEncInt:: Int -> B.Builder () @@ -184,7 +190,7 @@ encodeWord24LE v = do decodeWord24LE :: P.Parser Word32 decodeWord24LE = do - a <- fromIntegral <$> P.decodePrimLE @Word16 + a <- fromIntegral <$> P.decodeWord16LE b <- fromIntegral <$> P.anyWord8 return $! a .|. (b `unsafeShiftL` 16) {-# INLINE decodeWord24LE #-} diff --git a/benchmark/insert/MySQLHaskell.hs b/benchmark/insert/MySQLHaskell.hs index 710649d..9b4a508 100644 --- a/benchmark/insert/MySQLHaskell.hs +++ b/benchmark/insert/MySQLHaskell.hs @@ -4,60 +4,65 @@ module Main where import Control.Concurrent.Async +import Control.Concurrent.QSemN import Control.Monad import Database.MySQL.Base -import System.Environment -import System.IO.Streams (fold) -import qualified Data.ByteString as B +import qualified Z.Data.Builder as B +import qualified Z.Data.Vector as V +import Z.Data.CBytes as CB +import Z.Data.PrimRef +import qualified Z.IO.BIO as BIO +import Z.IO main :: IO () main = do args <- getArgs - case args of [threadNum] -> go (read threadNum) + case args of (_:threadNum:_) -> go (read (CB.unpack threadNum)) _ -> putStrLn "No thread number provided." go :: Int -> IO () go n = void . flip mapConcurrently [1..n] $ \ _ -> do - c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" + withResource (connect defaultConnectInfo { ciUser = "testMySQLHaskell" , ciDatabase = "testMySQLHaskell" - } + , ciPassword = "testMySQLHaskell123456!" + }) $ \ c -> do - execute_ c "BEGIN" - replicateM_ 1000 $ - execute_ c "INSERT INTO insert_test values (\ - \ 0 ,\ - \ b'1110000010101010' ,\ - \ -128 ,\ - \ 255 ,\ - \ -32768 ,\ - \ 65535 ,\ - \ -8388608 ,\ - \ 16777215 ,\ - \ -2147483648 ,\ - \ 4294967295 ,\ - \ -9223372036854775808 ,\ - \ 18446744073709551615 ,\ - \ 1234567890.0123456789 ,\ - \ 3.14159 ,\ - \ 3.1415926535 ,\ - \ '2016-08-08' ,\ - \ '2016-08-08 17:25:59' ,\ - \ '2016-08-08 17:25:59' ,\ - \ '-199:59:59' ,\ - \ 1999 ,\ - \ '12345678' ,\ - \ '韩冬真赞' ,\ - \ '12345678' ,\ - \ '12345678' ,\ - \ '12345678' ,\ - \ '韩冬真赞' ,\ - \ '12345678' ,\ - \ '韩冬真赞' ,\ - \ 'foo' ,\ - \ 'foo,bar')" + execute_ c "BEGIN" + replicateM_ 1000 $ + execute_ c "INSERT INTO insert_test values (\ + \ 0 ,\ + \ b'1110000010101010' ,\ + \ -128 ,\ + \ 255 ,\ + \ -32768 ,\ + \ 65535 ,\ + \ -8388608 ,\ + \ 16777215 ,\ + \ -2147483648 ,\ + \ 4294967295 ,\ + \ -9223372036854775808 ,\ + \ 18446744073709551615 ,\ + \ 1234567890.0123456789 ,\ + \ 3.14159 ,\ + \ 3.1415926535 ,\ + \ '2016-08-08' ,\ + \ '2016-08-08 17:25:59' ,\ + \ '2016-08-08 17:25:59' ,\ + \ '-199:59:59' ,\ + \ 1999 ,\ + \ '12345678' ,\ + \ '12345678' ,\ + \ '12345678' ,\ + \ '12345678' ,\ + \ '12345678' ,\ + \ '12345678' ,\ + \ '12345678' ,\ + \ '12345678' ,\ + \ 'foo' ,\ + \ 'foo,bar')" - execute_ c "COMMIT" - return () + execute_ c "COMMIT" + return () diff --git a/benchmark/insert/MySQLHaskellInsertMany.hs b/benchmark/insert/MySQLHaskellInsertMany.hs index 4033135..84b12f6 100644 --- a/benchmark/insert/MySQLHaskellInsertMany.hs +++ b/benchmark/insert/MySQLHaskellInsertMany.hs @@ -1,63 +1,69 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Main where import Control.Concurrent.Async +import Control.Concurrent.QSemN import Control.Monad import Database.MySQL.Base -import System.Environment -import System.IO.Streams (fold) -import qualified Data.ByteString as B +import qualified Z.Data.Builder as B +import qualified Z.Data.Vector as V +import Z.Data.CBytes as CB +import Z.Data.PrimRef +import qualified Z.IO.BIO as BIO +import Z.IO main :: IO () main = do args <- getArgs - case args of [threadNum] -> go (read threadNum) + case args of (_:threadNum:_) -> go (read (CB.unpack threadNum)) _ -> putStrLn "No thread number provided." go :: Int -> IO () go n = void . flip mapConcurrently [1..n] $ \ _ -> do - c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" + withResource (connect defaultConnectInfo { ciUser = "testMySQLHaskell" , ciDatabase = "testMySQLHaskell" - } + , ciPassword = "testMySQLHaskell123456!" + }) $ \ c -> do - execute_ c "BEGIN" - executeMany c "INSERT INTO insert_test values (\ - \ 0 ,\ - \ b'1110000010101010' ,\ - \ -128 ,\ - \ 255 ,\ - \ -32768 ,\ - \ 65535 ,\ - \ -8388608 ,\ - \ 16777215 ,\ - \ -2147483648 ,\ - \ 4294967295 ,\ - \ -9223372036854775808 ,\ - \ 18446744073709551615 ,\ - \ 1234567890.0123456789 ,\ - \ 3.14159 ,\ - \ 3.1415926535 ,\ - \ '2016-08-08' ,\ - \ '2016-08-08 17:25:59' ,\ - \ '2016-08-08 17:25:59' ,\ - \ '-199:59:59' ,\ - \ 1999 ,\ - \ '12345678' ,\ - \ '韩冬真赞' ,\ - \ '12345678' ,\ - \ '12345678' ,\ - \ '12345678' ,\ - \ '韩冬真赞' ,\ - \ '12345678' ,\ - \ '韩冬真赞' ,\ - \ 'foo' ,\ - \ 'foo,bar')" - (replicate 1000 []) + execute_ c "BEGIN" + executeMany @MySQLValue c "INSERT INTO insert_test values (\ + \ 0 ,\ + \ b'1110000010101010' ,\ + \ -128 ,\ + \ 255 ,\ + \ -32768 ,\ + \ 65535 ,\ + \ -8388608 ,\ + \ 16777215 ,\ + \ -2147483648 ,\ + \ 4294967295 ,\ + \ -9223372036854775808 ,\ + \ 18446744073709551615 ,\ + \ 1234567890.0123456789 ,\ + \ 3.14159 ,\ + \ 3.1415926535 ,\ + \ '2016-08-08' ,\ + \ '2016-08-08 17:25:59' ,\ + \ '2016-08-08 17:25:59' ,\ + \ '-199:59:59' ,\ + \ 1999 ,\ + \ '12345678' ,\ + \ '韩冬真赞' ,\ + \ '12345678' ,\ + \ '12345678' ,\ + \ '12345678' ,\ + \ '韩冬真赞' ,\ + \ '12345678' ,\ + \ '韩冬真赞' ,\ + \ 'foo' ,\ + \ 'foo,bar')" + (replicate 1000 []) - execute_ c "COMMIT" - return () + execute_ c "COMMIT" + return () diff --git a/benchmark/insert/MySQLHaskellPrepared.hs b/benchmark/insert/MySQLHaskellPrepared.hs index f8e0777..791616c 100644 --- a/benchmark/insert/MySQLHaskellPrepared.hs +++ b/benchmark/insert/MySQLHaskellPrepared.hs @@ -5,94 +5,99 @@ module Main where import Control.Concurrent.Async +import Control.Concurrent.QSemN import Control.Monad import Database.MySQL.Base -import System.Environment -import System.IO.Streams (fold) -import qualified Data.ByteString as B +import qualified Z.Data.Builder as B +import qualified Z.Data.Vector as V +import Z.Data.CBytes as CB +import Z.Data.PrimRef +import qualified Z.IO.BIO as BIO +import Z.IO import Data.Time.Calendar (fromGregorian) import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) main :: IO () main = do args <- getArgs - case args of [threadNum] -> go (read threadNum) + case args of (_:threadNum:_) -> go (read (CB.unpack threadNum)) _ -> putStrLn "No thread number provided." go :: Int -> IO () go n = void . flip mapConcurrently [1..n] $ \ _ -> do - c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" + withResource (connect defaultConnectInfo { ciUser = "testMySQLHaskell" , ciDatabase = "testMySQLHaskell" - } + , ciPassword = "testMySQLHaskell123456!" + }) $ \ c -> do - stmt <- prepareStmt c "INSERT INTO insert_test values (\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ? ,\ - \ ?)" + stmt <- prepareStmt c "INSERT INTO insert_test values (\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ? ,\ + \ ?)" - let bitV = 43744 -- 0b1010101011100000 - execute_ c "BEGIN" - replicateM_ 1000 $ executeStmt c stmt - [ MySQLInt32 0 - , MySQLBit bitV - , MySQLInt8 (-128) - , MySQLInt8U 255 - , MySQLInt16 (-32768) - , MySQLInt16U 65535 - , MySQLInt32 (-8388608) - , MySQLInt32U 16777215 - , MySQLInt32 (-2147483648) - , MySQLInt32U 4294967295 - , MySQLInt64 (-9223372036854775808) - , MySQLInt64U 18446744073709551615 - , MySQLDecimal 1234567890.0123456789 - , MySQLFloat 3.14159 - , MySQLDouble 3.1415926535 - , MySQLDate (fromGregorian 2016 08 08) - , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59)) - , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59)) - , MySQLTime 1 (TimeOfDay 199 59 59) - , MySQLYear 1999 - , MySQLText "12345678" - , MySQLText "韩冬真赞" - , MySQLBytes "12345678" - , MySQLBytes "12345678" - , MySQLBytes "12345678" - , MySQLText "韩冬真赞" - , MySQLBytes "12345678" - , MySQLText "韩冬真赞" - , MySQLText "foo" - , MySQLText "foo,bar" - ] + let bitV = 43744 -- 0b1010101011100000 + execute_ c "BEGIN" + replicateM_ 1000 $ executeStmt c stmt + [ MySQLInt32 0 + , MySQLBit bitV + , MySQLInt8 (-128) + , MySQLInt8U 255 + , MySQLInt16 (-32768) + , MySQLInt16U 65535 + , MySQLInt32 (-8388608) + , MySQLInt32U 16777215 + , MySQLInt32 (-2147483648) + , MySQLInt32U 4294967295 + , MySQLInt64 (-9223372036854775808) + , MySQLInt64U 18446744073709551615 + , MySQLDecimal 1234567890.0123456789 + , MySQLFloat 3.14159 + , MySQLDouble 3.1415926535 + , MySQLDate (fromGregorian 2016 08 08) + , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59)) + , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59)) + , MySQLTime 1 (TimeOfDay 199 59 59) + , MySQLYear 1999 + , MySQLText "12345678" + , MySQLText "韩冬真赞" + , MySQLBytes "12345678" + , MySQLBytes "12345678" + , MySQLBytes "12345678" + , MySQLText "韩冬真赞" + , MySQLBytes "12345678" + , MySQLText "韩冬真赞" + , MySQLText "foo" + , MySQLText "foo,bar" + ] - execute_ c "COMMIT" + execute_ c "COMMIT" diff --git a/benchmark/insert/insert.sql b/benchmark/insert/insert.sql index 70ae38c..b62c6de 100644 --- a/benchmark/insert/insert.sql +++ b/benchmark/insert/insert.sql @@ -3,15 +3,38 @@ USE testMySQLHaskell; -CREATE TABLE employees ( - emp_no INT NOT NULL, - birth_date DATE NOT NULL, - first_name VARCHAR(14) NOT NULL, - last_name VARCHAR(16) NOT NULL, - gender ENUM ('M','F') NOT NULL, - hire_date DATE NOT NULL, - PRIMARY KEY (emp_no) +DROP TABLE insert_test; + +CREATE TABLE insert_test ( + f1 INT , + f2 BIT(16) , + f3 TINYINT , + f4 TINYINT UNSIGNED , + f5 SMALLINT , + f6 SMALLINT UNSIGNED , + f7 MEDIUMINT , + f8 MEDIUMINT UNSIGNED , + f9 INT , + f10 INT UNSIGNED , + f11 BIGINT , + f12 BIGINT UNSIGNED , + f13 DECIMAL , + f14 FLOAT , + f15 DOUBLE , + f16 DATE , + f17 DATETIME , + f18 TIMESTAMP , + f19 TIME , + f20 YEAR , + f21 CHAR(100) , + f22 VARCHAR(100) , + f23 BINARY(100) , + f24 VARBINARY(100) , + f25 BLOB , + f26 TEXT , + f27 VARCHAR(100) , + f28 BINARY(100) , + f29 TEXT , + f30 TEXT ); -SELECT 'LOADING employees' as 'INFO'; -source load_employees.dump ; diff --git a/benchmark/insert/libmysql.cpp b/benchmark/insert/libmysql.cpp index c4dfc9e..8f9ce6e 100644 --- a/benchmark/insert/libmysql.cpp +++ b/benchmark/insert/libmysql.cpp @@ -8,7 +8,7 @@ #define THREAD_NUM 4 #define DBHOST "localhost" #define DBUSER "testMySQLHaskell" -#define DBPASS "" +#define DBPASS "testMySQLHaskell123456!" #define DBPORT 3306 #define DBNAME "testMySQLHaskell" #define DBSOCK NULL //"/var/lib/mysql/mysql.sock" diff --git a/benchmark/insert/mysql-haskell-bench.cabal b/benchmark/insert/mysql-haskell-bench.cabal index 2277de8..65b81c6 100644 --- a/benchmark/insert/mysql-haskell-bench.cabal +++ b/benchmark/insert/mysql-haskell-bench.cabal @@ -1,7 +1,7 @@ -- Initial mysql-haskell-bench.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ -name: mysql-haskell-bench +name: mysql-haskell-bench-insert version: 0.1.0.0 -- synopsis: -- description: @@ -18,15 +18,12 @@ cabal-version: >=1.10 library hs-source-dirs: ../../ exposed-modules: Database.MySQL.Base - , Database.MySQL.TLS - , Database.MySQL.OpenSSL , Database.MySQL.Protocol.Auth , Database.MySQL.Protocol.Command , Database.MySQL.Protocol.ColumnDef , Database.MySQL.Protocol.Packet , Database.MySQL.Protocol.MySQLValue , Database.MySQL.Protocol.Escape - , Database.MySQL.BinLog , Database.MySQL.BinLogProtocol.BinLogEvent , Database.MySQL.BinLogProtocol.BinLogValue , Database.MySQL.BinLogProtocol.BinLogMeta @@ -35,33 +32,24 @@ library other-modules: Database.MySQL.Connection , Database.MySQL.Query - build-depends: base >= 4.7 && <5 + build-depends: base >= 4.7 && < 5 , monad-loops == 0.4.* - , network >= 2.3 && < 3.0 - , io-streams >= 1.2 && < 2.0 - , tcp-streams == 0.5.* - , wire-streams >= 0.0.2 && < 0.1 - , binary == 0.8.* - , binary-ieee754 == 0.1.* - , binary-parsers >= 0.2.1 - , bytestring >= 0.10.2.0 - , text >= 1.1 && < 1.3 - , cryptonite == 0.* - , memory >= 0.8 , time >= 1.5.0 , scientific == 0.3.* - , bytestring-lexing == 0.5.* - , blaze-textual == 0.2.* - , word24 == 1.* - , tls >= 1.3.5 && <1.4 - , HsOpenSSL >=0.10.3 && <0.12 - , vector >= 0.8 + , Z-Data >= 1.0 && < 1.1 + , Z-IO >= 1.0 && < 1.1 + , Z-Botan >= 0.4 && < 0.5 + , word24 + , deepseq default-language: Haskell2010 default-extensions: DeriveDataTypeable , DeriveGeneric , MultiWayIf , OverloadedStrings + , TypeApplications + , DerivingStrategies + , DeriveAnyClass if os(mingw32) || os(windows) extra-libraries: eay32, ssl32 @@ -72,23 +60,24 @@ library include-dirs: /usr/local/opt/openssl/include else extra-libraries: crypto + c-sources: ../../cbits/escape.c executable bench - build-depends: base, mysql-haskell-bench, bytestring, io-streams, async + build-depends: base, mysql-haskell-bench, Z-Data, Z-IO, async default-language: Haskell2010 hs-source-dirs: . main-is: MySQLHaskell.hs ghc-options: -O2 -threaded -rtsopts executable bench-insert-many - build-depends: base, mysql-haskell-bench, bytestring, io-streams, async + build-depends: base, mysql-haskell-bench, Z-Data, Z-IO, async default-language: Haskell2010 hs-source-dirs: . main-is: MySQLHaskellInsertMany.hs ghc-options: -O2 -threaded -rtsopts executable benchPrepared - build-depends: base, mysql-haskell-bench, bytestring, io-streams, async, time + build-depends: base, mysql-haskell-bench, Z-Data, Z-IO, async, time default-language: Haskell2010 hs-source-dirs: . main-is: MySQLHaskellPrepared.hs diff --git a/benchmark/select/MySQLHaskell.hs b/benchmark/select/MySQLHaskell.hs index 96fb6de..d268a69 100644 --- a/benchmark/select/MySQLHaskell.hs +++ b/benchmark/select/MySQLHaskell.hs @@ -3,14 +3,14 @@ module Main where -import Control.Concurrent.Async +import Control.Concurrent.QSemN import Control.Monad import Database.MySQL.Base +import qualified Z.Data.Builder as B import Z.Data.PrimRef import Z.Data.CBytes as CB -import Z.IO.BIO +import qualified Z.IO.BIO as BIO import Z.IO -import qualified Data.ByteString as B main :: IO () main = do @@ -19,21 +19,24 @@ main = do _ -> putStdLn "No thread number provided." go :: Int -> IO () -go n = void . flip mapConcurrently [1..n] $ \ _ -> do - withResource (connect defaultConnectInfo { ciUser = "testMySQLHaskell" +go n = do + q <- newQSemN 0 + replicateM_ n . forkBa $ withResource (connect defaultConnectInfo { ciUser = "testMySQLHaskell" , ciDatabase = "testMySQLHaskell" , ciPassword = "testMySQLHaskell123456!" }) $ \ c -> do (fs, is) <- query_ c "SELECT * FROM employees" c <- newCounter 0 - runBIO $ is . counterNode c - (rowCount :: Int) <- readPrimIORef c - putStd "field name: " - forM_ fs $ \ f -> printStd (columnName f) >> putStdLn ", " - putStd "numbers of rows: " - printStd rowCount - + BIO.run_ $ is . BIO.counter c + (rowCount :: Int) <- readCounter c + putStdLn $ do + "field name: " + forM_ fs $ \ f -> B.text (columnName f) + ", numbers of rows: " + B.int rowCount + signalQSemN q 1 + waitQSemN q n diff --git a/benchmark/select/MySQLHaskellPrepared.hs b/benchmark/select/MySQLHaskellPrepared.hs index cd4c393..44aac4c 100644 --- a/benchmark/select/MySQLHaskellPrepared.hs +++ b/benchmark/select/MySQLHaskellPrepared.hs @@ -3,14 +3,15 @@ module Main where -import Control.Concurrent.Async +import Control.Concurrent.QSemN import Control.Monad import Database.MySQL.Base +import qualified Z.Data.Builder as B +import qualified Z.Data.Vector as V import Z.Data.CBytes as CB import Z.Data.PrimRef -import Z.IO.BIO +import qualified Z.IO.BIO as BIO import Z.IO -import qualified Data.ByteString as B main :: IO () main = do @@ -19,8 +20,9 @@ main = do _ -> putStdLn "No thread number provided." go :: Int -> IO () -go n = void . flip mapConcurrently [1..n] $ \ _ -> do - withResource (connect defaultConnectInfo { ciUser = "testMySQLHaskell" +go n = do + q <- newQSemN 0 + replicateM_ n . forkBa $ withResource (connect defaultConnectInfo { ciUser = "testMySQLHaskell" , ciDatabase = "testMySQLHaskell" , ciPassword = "testMySQLHaskell123456!" }) $ \ c -> do @@ -28,12 +30,16 @@ go n = void . flip mapConcurrently [1..n] $ \ _ -> do stmt <- prepareStmt c "SELECT * FROM employees" (fs, is) <- queryStmt c stmt [] c <- newCounter 0 - runBIO $ is . counterNode c - (rowCount :: Int) <- readPrimIORef c - putStd "field name: " - forM_ fs $ \ f -> printStd (columnName f) >> putStdLn ", " - putStd "numbers of rows: " - printStd rowCount + BIO.run_ $ is . BIO.counter c + (rowCount :: Int) <- readCounter c + putStdLn $ do + "field name: " + forM_ fs $ \ f -> B.text (columnName f) + ", numbers of rows: " + B.int rowCount + signalQSemN q 1 + waitQSemN q n + diff --git a/benchmark/select/libmysql_prepared.cpp b/benchmark/select/libmysql_prepared.cpp index 8034a64..6897f2e 100644 --- a/benchmark/select/libmysql_prepared.cpp +++ b/benchmark/select/libmysql_prepared.cpp @@ -8,7 +8,7 @@ #define THREAD_NUM 4 #define DBHOST "127.0.0.1" #define DBUSER "testMySQLHaskell" -#define DBPASS "" +#define DBPASS "testMySQLHaskell123456!" #define DBPORT 3306 #define DBNAME "testMySQLHaskell" #define DBSOCK NULL //"/var/lib/mysql/mysql.sock" @@ -39,8 +39,8 @@ void *func(void *arg) int int_data; char str_data[STRING_SIZE]; char str_data2[STRING_SIZE]; - my_bool is_null[6]; - my_bool error[6]; + bool is_null[6]; + bool error[6]; MYSQL_TIME ts; unsigned long length[6]; diff --git a/benchmark/select/mysql-haskell-bench.cabal b/benchmark/select/mysql-haskell-bench.cabal index 5c0b296..8c7673a 100644 --- a/benchmark/select/mysql-haskell-bench.cabal +++ b/benchmark/select/mysql-haskell-bench.cabal @@ -35,10 +35,11 @@ library , monad-loops == 0.4.* , time >= 1.5.0 , scientific == 0.3.* - , Z-Data >= 0.8.8 && < 0.9 - , Z-IO >= 0.8.1 && < 0.9 + , Z-Data >= 1.0 && < 1.1 + , Z-IO >= 1.0 && < 1.1 , Z-Botan >= 0.4 && < 0.5 , word24 + , deepseq default-language: Haskell2010 default-extensions: DeriveDataTypeable @@ -59,6 +60,7 @@ library else extra-libraries: crypto c-sources: ../../cbits/escape.c + -- ghc-options: -ddump-rule-firings executable bench build-depends: base, mysql-haskell-bench, bytestring, Z-Data, Z-IO, async @@ -82,11 +84,11 @@ executable bench -- ghc-options: -O2 -threaded -rtsopts executable benchPrepared - build-depends: base, mysql-haskell-bench, bytestring, Z-Data, Z-IO, async + build-depends: base, mysql-haskell-bench, bytestring, Z-Data, Z-IO, async, deepseq default-language: Haskell2010 hs-source-dirs: . main-is: MySQLHaskellPrepared.hs - ghc-options: -O2 -threaded -rtsopts + ghc-options: -O2 -threaded -rtsopts -eventlog -- executable benchFFI -- build-depends: base, async, mysql, text, mysql-simple, time diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal index 329ecdb..52acb1f 100644 --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -29,7 +29,7 @@ library Database.MySQL.Base --, Database.MySQL.TLS - -- Database.MySQL.BinLog + Database.MySQL.BinLog Database.MySQL.BinLogProtocol.BinLogEvent Database.MySQL.BinLogProtocol.BinLogValue Database.MySQL.BinLogProtocol.BinLogMeta @@ -40,9 +40,10 @@ library , time >= 1.5.0 , scientific == 0.3.* , word24 >= 2.0 && < 3.0 - , Z-Data >= 0.8.8 && < 0.9 - , Z-IO >= 0.8.1 && < 0.9 + , Z-Data >= 1.0 && < 1.1 + , Z-IO >= 1.0 && < 1.1 , Z-Botan >= 0.4 && < 0.5 + , deepseq default-language: Haskell2010