mysql-haskell 0.5.1.0 → 0.6.0.0

raw patch · 10 files changed

+115/−90 lines, 10 filesdep +binary-ieee754dep ~binaryPVP ok

version bump matches the API change (PVP)

Dependencies added: binary-ieee754

Dependency ranges changed: binary

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• Database/MySQL/Base.hs +3/−3
• Database/MySQL/BinLogProtocol/BinLogEvent.hs +7/−9
• Database/MySQL/BinLogProtocol/BinLogValue.hs +1/−0
• Database/MySQL/Protocol/Auth.hs +5/−4
• Database/MySQL/Protocol/ColumnDef.hs +4/−3
• Database/MySQL/Protocol/Command.hs +3/−2
• Database/MySQL/Protocol/MySQLValue.hs +77/−53
• Database/MySQL/Protocol/Packet.hs +7/−14
• mysql-haskell.cabal +3/−2

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

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

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

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

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

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

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

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

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

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