diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for mysql-haskell +## 0.6.0.0 -- 2016-10-25 + +* Use binary-ieee754 for older binary compatibility. +* Clean up `Database.MySQL.Protocol.MySQLValue` 's export. + ## 0.5.1.0 -- 2016-10-20 * Add `queryVector`, `queryVector_` and `queryStmtVector`. diff --git a/Database/MySQL/Base.hs b/Database/MySQL/Base.hs --- a/Database/MySQL/Base.hs +++ b/Database/MySQL/Base.hs @@ -33,7 +33,7 @@ , connectDetail , close , ping - -- * direct query + -- * Direct query , execute , executeMany , execute_ @@ -41,7 +41,7 @@ , queryVector_ , query , queryVector - -- * prepared query statement + -- * Prepared query statement , prepareStmt , prepareStmtDetail , executeStmt @@ -49,7 +49,7 @@ , queryStmtVector , closeStmt , resetStmt - -- * helpers + -- * Helpers , withTransaction , Query(..) , renderParams diff --git a/Database/MySQL/BinLogProtocol/BinLogEvent.hs b/Database/MySQL/BinLogProtocol/BinLogEvent.hs --- a/Database/MySQL/BinLogProtocol/BinLogEvent.hs +++ b/Database/MySQL/BinLogProtocol/BinLogEvent.hs @@ -18,7 +18,7 @@ import Control.Monad import Control.Monad.Loops (untilM) import Data.Binary -import Data.Binary.Get +import Data.Binary.Parser import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -107,17 +107,15 @@ getFromBinLogPacket :: Get a -> BinLogPacket -> IO a getFromBinLogPacket g (BinLogPacket _ _ _ _ _ _ body _ ) = - case pushEndOfInput $ pushChunks (runGetIncremental g) body of - Done _ _ r -> return r - Fail buf offset errmsg -> throwIO (DecodePacketFailed buf offset errmsg) - _ -> error "getFromBinLogPacket: impossible!" + case parseDetailLazy g body of + Left (buf, offset, errmsg) -> throwIO (DecodePacketFailed buf offset errmsg) + Right (_, _, r ) -> return r getFromBinLogPacket' :: (BinLogEventType -> Get a) -> BinLogPacket -> IO a getFromBinLogPacket' g (BinLogPacket _ typ _ _ _ _ body _ ) = - case pushEndOfInput $ pushChunks (runGetIncremental (g typ)) body of - Done _ _ r -> return r - Fail buf offset errmsg -> throwIO (DecodePacketFailed buf offset errmsg) - _ -> error "getFromBinLogPacket': impossible!" + case parseDetailLazy (g typ) body of + Left (buf, offset, errmsg) -> throwIO (DecodePacketFailed buf offset errmsg) + Right (_, _, r ) -> return r -------------------------------------------------------------------------------- diff --git a/Database/MySQL/BinLogProtocol/BinLogValue.hs b/Database/MySQL/BinLogProtocol/BinLogValue.hs --- a/Database/MySQL/BinLogProtocol/BinLogValue.hs +++ b/Database/MySQL/BinLogProtocol/BinLogValue.hs @@ -15,6 +15,7 @@ import Control.Applicative import Data.Binary.Get +import Data.Binary.IEEE754 import Data.Binary.Put import Data.Bits import Data.ByteString (ByteString) diff --git a/Database/MySQL/Protocol/Auth.hs b/Database/MySQL/Protocol/Auth.hs --- a/Database/MySQL/Protocol/Auth.hs +++ b/Database/MySQL/Protocol/Auth.hs @@ -20,6 +20,7 @@ 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 @@ -90,14 +91,14 @@ sv <- getByteStringNul cid <- getWord32le salt1 <- getByteString 8 - skip 1 -- 0x00 + skipN 1 -- 0x00 capL <- getWord16le charset <- getWord8 status <- getWord16le capH <- getWord16le let cap = fromIntegral capH `shiftL` 16 .|. fromIntegral capL authPluginLen <- getWord8 - skip 10 -- 10 * 0x00 + skipN 10 -- 10 * 0x00 salt2 <- if (cap .&. CLIENT_SECURE_CONNECTION) == 0 then pure B.empty else getByteStringNul -- This is different with the MySQL document here @@ -128,7 +129,7 @@ a <- getWord32le m <- getWord32le c <- getWord8 - skip 23 + skipN 23 n <- getByteStringNul return $ Auth a m c n B.empty B.empty @@ -155,7 +156,7 @@ } deriving (Show, Eq) getSSLRequest :: Get SSLRequest -getSSLRequest = SSLRequest <$> getWord32le <*> getWord32le <*> getWord8 <* skip 23 +getSSLRequest = SSLRequest <$> getWord32le <*> getWord32le <*> getWord8 <* skipN 23 putSSLRequest :: SSLRequest -> Put putSSLRequest (SSLRequest cap m c) = do diff --git a/Database/MySQL/Protocol/ColumnDef.hs b/Database/MySQL/Protocol/ColumnDef.hs --- a/Database/MySQL/Protocol/ColumnDef.hs +++ b/Database/MySQL/Protocol/ColumnDef.hs @@ -19,6 +19,7 @@ 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) @@ -44,19 +45,19 @@ getField :: Get ColumnDef getField = ColumnDef - <$> (skip 4 -- const "def" + <$> (skipN 4 -- const "def" *> getLenEncBytes) -- db <*> getLenEncBytes -- table <*> getLenEncBytes -- origTable <*> getLenEncBytes -- name <*> getLenEncBytes -- origName - <* skip 1 -- const 0x0c + <* skipN 1 -- const 0x0c <*> getWord16le -- charset <*> getWord32le -- length <*> getFieldType -- type <*> getWord16le -- flags <*> getWord8 -- decimals - <* skip 2 -- const 0x00 0x00 + <* skipN 2 -- const 0x00 0x00 {-# INLINE getField #-} putField :: ColumnDef -> Put diff --git a/Database/MySQL/Protocol/Command.hs b/Database/MySQL/Protocol/Command.hs --- a/Database/MySQL/Protocol/Command.hs +++ b/Database/MySQL/Protocol/Command.hs @@ -19,6 +19,7 @@ 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 @@ -97,11 +98,11 @@ getStmtPrepareOK :: Get StmtPrepareOK getStmtPrepareOK = do - skip 1 -- OK byte + skipN 1 -- OK byte stmtid <- getWord32le cc <- fromIntegral <$> getWord16le pc <- fromIntegral <$> getWord16le - skip 1 -- reserved + skipN 1 -- reserved wc <- fromIntegral <$> getWord16le return (StmtPrepareOK stmtid cc pc wc) {-# INLINE getStmtPrepareOK #-} diff --git a/Database/MySQL/Protocol/MySQLValue.hs b/Database/MySQL/Protocol/MySQLValue.hs --- a/Database/MySQL/Protocol/MySQLValue.hs +++ b/Database/MySQL/Protocol/MySQLValue.hs @@ -13,13 +13,32 @@ -} -module Database.MySQL.Protocol.MySQLValue where +module Database.MySQL.Protocol.MySQLValue + ( -- * MySQLValue decoder and encoder + MySQLValue(..) + , putParamMySQLType + , getTextField + , putTextField + , getTextRow + , getTextRowVector + , getBinaryField + , putBinaryField + , getBinaryRow + , getBinaryRowVector + -- * Internal utilities + , getBits + , BitMap(..) + , isColumnSet + , isColumnNull + , makeNullMap + ) where import qualified Blaze.Text as Textual import Control.Applicative import Control.Monad -import Data.Binary.Parser 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 @@ -99,7 +118,7 @@ | MySQLNull deriving (Show, Eq, Generic) --- | Decide if usigned bit(0x80) and 'FieldType' for 'MySQLValue's. +-- | Put 'FieldType' and usigned bit(0x80/0x00) for 'MySQLValue's. -- putParamMySQLType :: MySQLValue -> Put putParamMySQLType (MySQLDecimal _) = putFieldType mySQLTypeDecimal >> putWord8 0x00 @@ -128,36 +147,36 @@ -- | Text protocol decoder getTextField :: ColumnDef -> Get MySQLValue getTextField f - | t == mySQLTypeNull = pure MySQLNull + | 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 == 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 == 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 == 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 == mySQLTypeDateTime2 = feedLenEncBytes t MySQLDateTime $ \ bs -> + LocalTime <$> dateParser bs <*> timeParser (B.unsafeDrop 11 bs) | t == mySQLTypeDate - || t == mySQLTypeNewDate = feedLenEncBytes t MySQLDate dateParser + || 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 == 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 == mySQLTypeGeometry = MySQLGeometry <$> getLenEncBytes | t == mySQLTypeVarChar || t == mySQLTypeEnum || t == mySQLTypeSet @@ -166,11 +185,11 @@ || t == mySQLTypeLongBlob || t == mySQLTypeBlob || t == mySQLTypeVarString - || t == mySQLTypeString = (if isText then MySQLText . T.decodeUtf8 else MySQLBytes) <$> getLenEncBytes + || t == mySQLTypeString = (if isText then MySQLText . T.decodeUtf8 else MySQLBytes) <$> getLenEncBytes - | t == mySQLTypeBit = MySQLBit <$> (getBits =<< getLenEncInt) + | t == mySQLTypeBit = MySQLBit <$> (getBits =<< getLenEncInt) - | otherwise = fail $ "Database.MySQL.Protocol.MySQLValue: missing text decoder for " ++ show t + | otherwise = fail $ "Database.MySQL.Protocol.MySQLValue: missing text decoder for " ++ show t where t = columnType f isUnsigned = flagUnsigned (columnFlags f) @@ -231,6 +250,12 @@ putTextField (MySQLBit b) = do putBuilder "b\'" putBuilder . execPut $ putTextBits b putCharUtf8 '\'' + 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" putInQuotes :: Put -> Put @@ -243,7 +268,7 @@ getTextRow fs = forM fs $ \ f -> do p <- peek if p == 0xFB - then skip 1 >> return MySQLNull + then skipN 1 >> return MySQLNull else getTextField f {-# INLINE getTextRow #-} @@ -251,7 +276,7 @@ getTextRowVector fs = V.forM fs $ \ f -> do p <- peek if p == 0xFB - then skip 1 >> return MySQLNull + then skipN 1 >> return MySQLNull else getTextField f {-# INLINE getTextRowVector #-} @@ -367,14 +392,13 @@ pure $! (realToFrac s + realToFrac ms / 1000000 :: Pico) --- | convert a bit sequence to a Word64 +-- | Get a bit sequence as a Word64 -- -- 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 + if | bytes == 0 || bytes == 1 -> fromIntegral <$> getWord8 | bytes == 2 -> fromIntegral <$> getWord16be | bytes == 3 -> fromIntegral <$> getWord24be | bytes == 4 -> fromIntegral <$> getWord32be @@ -386,10 +410,6 @@ \wrong bit length size: " ++ show bytes {-# INLINE getBits #-} -putTextBits :: Word64 -> Put -putTextBits word = forM_ [63,62..0] $ \ pos -> - if word `testBit` pos then putCharUtf8 '1' else putCharUtf8 '0' -{-# INLINE putTextBits #-} -------------------------------------------------------------------------------- -- | Binary protocol encoder @@ -461,15 +481,15 @@ -- getBinaryRow :: [ColumnDef] -> Int -> Get [MySQLValue] getBinaryRow fields flen = do - skip 1 -- 0x00 + skipN 1 -- 0x00 let maplen = (flen + 7 + 2) `shiftR` 3 - nullmap <- getByteString maplen + nullmap <- BitMap <$> getByteString maplen go fields nullmap 0 where - go :: [ColumnDef] -> ByteString -> Int -> Get [MySQLValue] + go :: [ColumnDef] -> BitMap -> Int -> Get [MySQLValue] go [] _ _ = pure [] go (f:fs) nullmap pos = do - r <- if isNull_ nullmap pos + r <- if isColumnNull nullmap pos then return MySQLNull else getBinaryField f let pos' = pos + 1 @@ -479,19 +499,13 @@ getBinaryRowVector :: V.Vector ColumnDef -> Int -> Get (V.Vector MySQLValue) getBinaryRowVector fields flen = do - skip 1 -- 0x00 + skipN 1 -- 0x00 let maplen = (flen + 7 + 2) `shiftR` 3 - nullmap <- getByteString maplen + nullmap <- BitMap <$> getByteString maplen (`V.imapM` fields) $ \ pos f -> - if isNull_ nullmap pos then return MySQLNull else getBinaryField f + if isColumnNull nullmap pos then return MySQLNull else getBinaryField f {-# INLINE getBinaryRowVector #-} --- This 'isNull_' is special for offset = 2 -isNull_ nullmap pos = - let (i, j) = (pos + 2) `quotRem` 8 - in (nullmap `B.unsafeIndex` i) `testBit` j -{-# INLINE isNull_ #-} - -------------------------------------------------------------------------------- -- | Use 'ByteString' to present a bitmap. -- @@ -510,7 +524,7 @@ -- newtype BitMap = BitMap { fromBitMap :: ByteString } deriving (Eq, Show) --- | test if a column is set +-- | Test if a column is set(binlog protocol). -- -- The number counts from left to right. -- @@ -520,7 +534,17 @@ in (bitmap `B.unsafeIndex` i) `testBit` j {-# INLINE isColumnSet #-} --- | make a nullmap for params without offset. +-- | Test if a column is null(binary protocol). +-- +-- The number counts from left to right. +-- +isColumnNull :: BitMap -> Int -> Bool +isColumnNull (BitMap nullmap) pos = + let (i, j) = (pos + 2) `quotRem` 8 + in (nullmap `B.unsafeIndex` i) `testBit` j +{-# INLINE isColumnNull #-} + +-- | Make a nullmap for params(binary protocol) without offset. -- makeNullMap :: [MySQLValue] -> BitMap makeNullMap values = BitMap . B.pack $ go values 0x00 0 diff --git a/Database/MySQL/Protocol/Packet.hs b/Database/MySQL/Protocol/Packet.hs --- a/Database/MySQL/Protocol/Packet.hs +++ b/Database/MySQL/Protocol/Packet.hs @@ -82,16 +82,9 @@ {-# INLINE decodeFromPacket #-} getFromPacket :: Get a -> Packet -> IO a -getFromPacket g (Packet _ _ body) = - case body of - (L.Chunk bs lbs) -> case pushEndOfInput (pushChunks (parse g bs) lbs) of - Done _ _ r -> return r - Fail buf offset errmsg -> throwIO (DecodePacketFailed buf offset errmsg) - _ -> error "getFromPacket: impossible error!" - L.Empty -> case pushEndOfInput (parse g B.empty) of - Done _ _ r -> return r - Fail buf offset errmsg -> throwIO (DecodePacketFailed buf offset errmsg) - _ -> error "getFromPacket: impossible error!" +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 @@ -126,7 +119,7 @@ } deriving (Show, Eq) getOK :: Get OK -getOK = OK <$ skip 1 +getOK = OK <$ skipN 1 <*> getLenEncInt <*> getLenEncInt <*> getWord16le @@ -155,9 +148,9 @@ } deriving (Show, Eq) getERR :: Get ERR -getERR = ERR <$ skip 1 +getERR = ERR <$ skipN 1 <*> getWord16le - <* skip 1 + <* skipN 1 <*> getByteString 5 <*> getRemainingByteString {-# INLINE getERR #-} @@ -183,7 +176,7 @@ } deriving (Show, Eq) getEOF :: Get EOF -getEOF = EOF <$ skip 1 +getEOF = EOF <$ skipN 1 <*> getWord16le <*> getWord16le {-# INLINE getEOF #-} diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -1,5 +1,5 @@ name: mysql-haskell -version: 0.5.1.0 +version: 0.6.0.0 synopsis: pure haskell MySQL driver description: pure haskell MySQL driver license: BSD3 @@ -47,7 +47,8 @@ , io-streams >= 1.2 && < 2.0 , tcp-streams >= 0.4 && < 0.6 , wire-streams >= 0.1 - , binary >= 0.8.4 + , binary == 0.8.* + , binary-ieee754 == 0.1.* , binary-parsers >= 0.2.1 , bytestring >= 0.10.2.0 , text >= 1.1 && < 1.3