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
import Data.Word
import Database.MySQL.BinLogProtocol.BinLogMeta
import Database.MySQL.Protocol.MySQLValue
import Database.MySQL.Protocol.Packet
import GHC.Generics (Generic)
data BinLogValue
= BinLogTiny !Int8
| BinLogShort !Int16
| BinLogInt24 !Int24
| BinLogLong !Int32
| BinLogLongLong !Int64
| BinLogFloat !Float
| BinLogDouble !Double
| BinLogBit !Word64
| BinLogTimeStamp !Word32
| BinLogTimeStamp2 !Word32 !Word32
| BinLogDateTime !Word16 !Word8 !Word8 !Word8 !Word8 !Word8
| BinLogDateTime2 !Word16 !Word8 !Word8 !Word8 !Word8 !Word8 !Word32
| BinLogDate !Word16 !Word8 !Word8
| BinLogTime !Word8 !Word16 !Word8 !Word8
| BinLogTime2 !Word8 !Word16 !Word8 !Word8 !Word32
| BinLogYear !Word16
| BinLogNewDecimal !Scientific
| BinLogEnum !Word16
| BinLogSet !Word64
| BinLogBytes !ByteString
| BinLogGeometry !ByteString
| BinLogNull
deriving (Show, Eq, Generic)
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
getBinLogField BINLOG_TYPE_DATE = do
i <- getWord24le
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
ms <- fromIntegral <$> getMicroSecond fsp
pure (BinLogTimeStamp2 s ms)
getBinLogField BINLOG_TYPE_DATETIME = do
i <- getWord64le
let (yyyy, i') = i `quotRem` 10000000000
(mm, i'') = i' `quotRem` 100000000
(dd, i''') = i'' `quotRem` 1000000
(h, i'''') = i''' `quotRem` 10000
(m, s) = i'''' `quotRem` 100
pure (BinLogDateTime (fromIntegral yyyy)
(fromIntegral mm)
(fromIntegral dd)
(fromIntegral h)
(fromIntegral m)
(fromIntegral s))
getBinLogField (BINLOG_TYPE_DATETIME2 fsp) = do
iPart <- getWord40be
let yyyymm = iPart `shiftR` 22 .&. 0x01FFFF
(yyyy, mm) = yyyymm `quotRem` 13
yyyy' = fromIntegral yyyy
mm' = fromIntegral mm
dd = fromIntegral $ iPart `shiftR` 17 .&. 0x1F
h = fromIntegral $ iPart `shiftR` 12 .&. 0x1F
m = fromIntegral $ iPart `shiftR` 6 .&. 0x3F
s = fromIntegral $ iPart .&. 0x3F
ms <- fromIntegral <$> getMicroSecond fsp
pure (BinLogDateTime2 yyyy' mm' dd h m s ms)
getBinLogField BINLOG_TYPE_TIME = do
i <- getWord24le
let i' = fromIntegral i :: Int24
sign = if i' >= 0 then 1 else 0
let (h, i'') = i' `quotRem` 10000
(m, s) = i'' `quotRem` 100
pure (BinLogTime sign (fromIntegral (abs h))
(fromIntegral (abs m))
(fromIntegral (abs s)))
getBinLogField (BINLOG_TYPE_TIME2 fsp) = do
iPart <- getWord24be
let sign = fromIntegral $ iPart `shiftR` 23
iPart' = if sign == 0 then 0x800000 iPart 1 else iPart
h = fromIntegral (iPart' `shiftR` 12) .&. 0x03FF
m = fromIntegral (iPart' `shiftR` 6) .&. 0x3F
s = fromIntegral iPart' .&. 0x3F
ms <- abs <$> getMicroSecond fsp
let ms' = abs (fromIntegral ms :: Int)
pure (BinLogTime2 sign h m s (fromIntegral ms'))
getBinLogField BINLOG_TYPE_YEAR = do
y <- getWord8
pure $! if y == 0 then BinLogYear 0 else BinLogYear (1900 + fromIntegral y)
getBinLogField (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)
len = ucISize + cISize + ucFSize + cFSize
buf <- getByteString (fromIntegral len)
let fb = buf `B.unsafeIndex` 0
sign = if fb .&. 0x80 == 0x80 then 1 else 0 :: Word8
buf' = (fb `xor` 0x80) `B.cons` B.tail buf
buf'' = if sign == 1 then buf'
else B.map (xor 0xFF) buf'
iPart = fromIntegral (getCompressed cISize (B.unsafeTake cISize buf'')) * (blockSize ^ ucI)
+ getUncompressed ucI (B.unsafeDrop cISize buf'')
let buf''' = B.unsafeDrop (ucISize + cISize) buf''
fPart = getUncompressed ucF (B.unsafeTake ucFSize buf''') * (10 ^ cF)
+ fromIntegral (getCompressed cFSize (B.unsafeDrop ucFSize buf'''))
let sci = scientific (iPart * 10 ^ scale + fPart) (negate $ fromIntegral scale)
sci' = if sign == 0 then negate sci else sci
pure (BinLogNewDecimal sci')
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
getBinLogRow :: [BinLogMeta] -> BitMap -> Get [BinLogValue]
getBinLogRow metas pmap = do
let plen = B.foldl' (\acc word8 -> acc + popCount word8) 0 (fromBitMap pmap)
maplen = (plen + 7) `shiftR` 3
nullmap <- getByteString maplen
go metas (BitMap nullmap) 0 pmap 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'