mysql-haskell (empty) → 0.1.0.0
raw patch · 25 files changed
+4517/−0 lines, 25 filesdep +basedep +binarydep +blaze-textualsetup-changed
Dependencies added: base, binary, blaze-textual, bytestring, bytestring-lexing, cryptonite, io-streams, memory, monad-loops, mysql-haskell, network, scientific, tasty, tasty-hunit, tcp-streams, text, time, tls, transformers, wire-streams, word24
Files
- ChangeLog.md +5/−0
- Database/MySQL/Base.hs +205/−0
- Database/MySQL/BinLog.hs +208/−0
- Database/MySQL/BinLogProtocol/BinLogEvent.hs +292/−0
- Database/MySQL/BinLogProtocol/BinLogMeta.hs +120/−0
- Database/MySQL/BinLogProtocol/BinLogValue.hs +323/−0
- Database/MySQL/Connection.hs +287/−0
- Database/MySQL/Protocol/Auth.hs +103/−0
- Database/MySQL/Protocol/ColumnDef.hs +171/−0
- Database/MySQL/Protocol/Command.hs +129/−0
- Database/MySQL/Protocol/Escape.hs +107/−0
- Database/MySQL/Protocol/MySQLValue.hs +528/−0
- Database/MySQL/Protocol/Packet.hs +294/−0
- Database/MySQL/Query.hs +49/−0
- LICENSE +30/−0
- README.md +124/−0
- Setup.hs +2/−0
- mysql-haskell.cabal +81/−0
- test/BinLog.hs +234/−0
- test/BinLogNew.hs +101/−0
- test/BinaryRow.hs +375/−0
- test/BinaryRowNew.hs +111/−0
- test/Main.hs +157/−0
- test/TextRow.hs +372/−0
- test/TextRowNew.hs +109/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for mysql-haskell++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ Database/MySQL/Base.hs view
@@ -0,0 +1,205 @@+{-|+Module : Database.MySQL.Base+Description : Prelude of mysql-haskell+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++This module provide common MySQL operations,++NOTEs on 'Exception's: This package use 'Exception' to deal with unexpected situations,+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.+ * 'DecodePacketException': there's a packet we can't decode.+ * 'WrongParamsCount': you're giving wrong number of params to 'renderParams'.++Both 'UnexpectedPacket' and 'DecodePacketException' may indicate a bug of this library rather your code, so please report!++-}+module Database.MySQL.Base+ ( -- * Setting up and control connection+ MySQLConn+ , ConnectInfo(..)+ , defaultConnectInfo+ , connect+ , connectDetail+ , close+ , ping+ -- * direct query+ , execute+ , execute_+ , query_+ , query+ -- * prepared query statement+ , prepareStmt+ , prepareStmtDetail+ , executeStmt+ , queryStmt+ , closeStmt+ , resetStmt+ -- * MySQL protocol+ , module Database.MySQL.Protocol.Auth+ , module Database.MySQL.Protocol.Command+ , module Database.MySQL.Protocol.ColumnDef+ , module Database.MySQL.Protocol.Packet+ , module Database.MySQL.Protocol.MySQLValue+ -- * helpers+ , Query(..)+ , renderParams+ , command+ , Stream.skipToEof+ ) where++import Control.Applicative+import Control.Exception (throwIO)+import Control.Monad+import Data.IORef (writeIORef)+import Database.MySQL.Connection+import Database.MySQL.Protocol.Auth+import Database.MySQL.Protocol.ColumnDef+import Database.MySQL.Protocol.Command+import Database.MySQL.Protocol.MySQLValue+import Database.MySQL.Protocol.Packet++import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Stream+import Database.MySQL.Query++--------------------------------------------------------------------------------++-- | Execute a MySQL query with parameters which don't return a resultSet.+--+-- The query may contain placeholders @?@, for filling up parameters, the parameters+-- will be escaped before get filled into the query, please DO NOT enable @NO_BACKSLASH_ESCAPES@,+-- and you should consider using prepared statement if this's not an one shot query.+--+execute :: MySQLConn -> Query -> [MySQLValue] -> IO OK+execute conn qry params = execute_ conn (renderParams qry params)++-- | Execute a MySQL query which don't return a resultSet.+--+execute_ :: MySQLConn -> Query -> IO OK+execute_ conn (Query qry) = command conn (COM_QUERY qry)++{-+executeBatch :: MySQLConn -> Query -> OutputStream [MySQLValue] -> IO (InputStream OK)+executeBatch+-}++-- | Execute a MySQL query which return a result-set with parameters.+--+-- Note that you must fully consumed the result-set before start a new query on+-- the same 'MySQLConn', or an 'UnconsumedResultSet' will be thrown.+-- if you want to skip the result-set, use 'Stream.skipToEof'.+--+query :: MySQLConn -> Query -> [MySQLValue] -> IO ([ColumnDef], InputStream [MySQLValue])+query conn qry params = query_ conn (renderParams qry params)++-- | Execute a MySQL query which return a resultSet.+--+query_ :: MySQLConn -> Query -> IO ([ColumnDef], InputStream [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+ 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)++-- | Ask MySQL to prepare a query statement.+--+prepareStmt :: 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 (colCnt == 0) (void (readPacket is)) -- EOF+ _ <- replicateM colCnt (readPacket is)+ _ <- unless (paramCnt == 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', table's 'ColumnDef'.+--+prepareStmtDetail :: MySQLConn -> Query -> IO (StmtPrepareOK, [ColumnDef], [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 (colCnt == 0) (void (readPacket is)) -- EOF+ cdefs <- replicateM colCnt ((decodeFromPacket <=< readPacket) is)+ _ <- unless (paramCnt == 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+ writeCommand (COM_STMT_CLOSE stid) os++-- | Ask MySQL to reset a query statement, all previous resultset will be cleared.+--+resetStmt :: MySQLConn -> StmtID -> IO ()+resetStmt (MySQLConn is os _ consumed) 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.+--+executeStmt :: MySQLConn -> StmtID -> [MySQLValue] -> IO OK+executeStmt conn stid params = command conn (COM_STMT_EXECUTE stid params)++-- | Execute prepared query statement with parameters, expecting resultset.+--+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) 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 -- fast path for decode rows+ | isEOF q -> writeIORef consumed True >> return Nothing+ | isERR q -> decodeFromPacket q >>= throwIO . ERRException+ | otherwise -> throwIO (UnexpectedPacket q)+ return (fields, rows)
+ Database/MySQL/BinLog.hs view
@@ -0,0 +1,208 @@+{-|+Module : Database.MySQL.BinLog+Description : Binary protocol toolkit+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++This module provide tools for binlog listening and row based binlog decoding.+-}++module Database.MySQL.BinLog+ ( -- * binlog utilities+ SlaveID+ , BinLogTracker(..)+ , registerPesudoSlave+ , dumpBinLog+ , RowBinLogEvent(..)+ , decodeRowBinLogEvent+ -- * helpers+ , getLastBinLogTracker+ , isCheckSumEnabled+ , isSemiSyncEnabled+ -- * re-export+ , module Database.MySQL.BinLogProtocol.BinLogEvent+ , module Database.MySQL.BinLogProtocol.BinLogValue+ ) where++import Control.Applicative+import Control.Exception (throwIO)+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.Word+import Database.MySQL.Base+import Database.MySQL.BinLogProtocol.BinLogEvent+import Database.MySQL.BinLogProtocol.BinLogValue+import Database.MySQL.Connection+import System.IO.Streams (InputStream,+ OutputStream)+import qualified System.IO.Streams as Stream++type SlaveID = Word32++-- | binlog filename and position to start listening.+--+data BinLogTracker = BinLogTracker+ { btFileName :: {-# UNPACK #-} !ByteString+ , btNextPos :: {-# UNPACK #-} !Word32+ } deriving (Show, Eq)++-- | Register a pesudo slave to master, although MySQL document suggests you should call this+-- before calling 'dumpBinLog', but it seems it's not really necessary.+--+registerPesudoSlave :: MySQLConn -> SlaveID -> IO OK+registerPesudoSlave conn sid = command conn (COM_REGISTER_SLAVE sid "" "" "" 0 0 0)++-- | Setup binlog listening on given connection, during listening+-- the connection *can not* be used to do query, or an 'UnconsumedResultSet' will be thrown.+--+dumpBinLog :: MySQLConn -- ^ connection to be listened+ -> SlaveID -- ^ a number for our pesudo slave.+ -> 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)+dumpBinLog conn@(MySQLConn is os _ consumed) sid (BinLogTracker initfn initpos) wantAck = do+ guardUnconsumed conn+ checksum <- isCheckSumEnabled conn+ when checksum $ void $ execute_ conn "SET @master_binlog_checksum = @@global.binlog_checksum"+ semiAck <- isSemiSyncEnabled conn+ let needAck = semiAck && wantAck+ when needAck . void $ execute_ conn "SET @rpl_semi_sync_slave = 1"+ writeCommand (COM_BINLOG_DUMP initpos 0x00 sid initfn) os+ writeIORef consumed False++ rp <- skipToPacketT (readBinLogPacket checksum needAck is) BINLOG_ROTATE_EVENT+ re <- getFromBinLogPacket getRotateEvent rp+ fref <- newIORef (rFileName re)++ p <- skipToPacketT (readBinLogPacket checksum needAck is) BINLOG_FORMAT_DESCRIPTION_EVENT+ replyAck needAck p fref os+ fmt <- getFromBinLogPacket getFormatDescription p++ es <- Stream.makeInputStream $ do+ q <- readBinLogPacket checksum needAck is+ case q of+ Nothing -> writeIORef consumed True >> return Nothing+ Just q' -> do when (blEventType q' == BINLOG_ROTATE_EVENT) $ do+ e <- getFromBinLogPacket getRotateEvent q'+ writeIORef' fref (rFileName e)+ replyAck needAck q' fref os+ return q+ return (fmt, fref, es)+ where+ skipToPacketT iop typ = do+ p <- iop+ case p of+ Just p' -> do+ if blEventType p' == typ then return p' else skipToPacketT iop typ+ Nothing -> throwIO NetworkException++ replyAck needAck p fref os' = when (needAck && blSemiAck p) $ do+ fn <- readIORef fref+ Stream.write (Just (makeSemiAckPacket (blLogPos p) fn)) os'++ makeSemiAckPacket pos fn = putToPacket 0 $ do+ putWord8 0xEF -- semi-ack+ putWord64le pos+ putByteString fn++ readBinLogPacket checksum needAck is' = do+ p <- readPacket is'+ if | isOK p -> Just <$> getFromPacket (getBinLogPacket checksum needAck) p+ | isEOF p -> return Nothing+ | isERR p -> decodeFromPacket p >>= throwIO . ERRException++-- | Row based biblog event type.+--+-- It's recommended to call 'enableRowQueryEvent' before 'dumpBinLog', so that you can get+-- 'RowQueryEvent' in row based binlog(it's important for detect a table change for example).+--+-- a 'BinLogTracker' is included so that you can roll up your own HA solutions,+-- for example, writing 'BinLogPacket' to a zookeeper when you done with an event.+--+data RowBinLogEvent+ = RowQueryEvent !BinLogTracker !QueryEvent'+ | RowDeleteEvent !BinLogTracker !TableMapEvent !DeleteRowsEvent+ | RowWriteEvent !BinLogTracker !TableMapEvent !WriteRowsEvent+ | RowUpdateEvent !BinLogTracker !TableMapEvent !UpdateRowsEvent+ deriving (Show, Eq)++-- | decode row based event from 'BinLogPacket' stream.+decodeRowBinLogEvent :: (FormatDescription, IORef ByteString, InputStream BinLogPacket)+ -> IO (InputStream RowBinLogEvent)+decodeRowBinLogEvent (fd', fref', is') = Stream.makeInputStream (loop fd' fref' is')+ where+ loop fd fref is = do+ p <- Stream.read is+ case p of+ Nothing -> return Nothing+ Just p' -> do+ let t = blEventType p'+ if | t == BINLOG_ROWS_QUERY_EVENT -> do+ tr <- track p' fref+ e <- getFromBinLogPacket getQueryEvent' p'+ pure (Just (RowQueryEvent tr e))+ | t == BINLOG_TABLE_MAP_EVENT -> do+ tme <- getFromBinLogPacket (getTableMapEvent fd) p'+ q <- Stream.read is+ case q of+ Nothing -> return Nothing+ Just q' -> do+ let u = blEventType q'+ if | u == BINLOG_WRITE_ROWS_EVENTv1 || u == BINLOG_WRITE_ROWS_EVENTv2 -> do+ tr <- track q' fref+ e <- getFromBinLogPacket' (getWriteRowEvent fd tme) q'+ pure (Just (RowWriteEvent tr tme e))+ | u == BINLOG_DELETE_ROWS_EVENTv1 || u == BINLOG_DELETE_ROWS_EVENTv2 -> do+ tr <- track q' fref+ e <- getFromBinLogPacket' (getDeleteRowEvent fd tme) q'+ pure (Just (RowDeleteEvent tr tme e))+ | u == BINLOG_UPDATE_ROWS_EVENTv1 || u == BINLOG_UPDATE_ROWS_EVENTv2 -> do+ tr <- track q' fref+ e <- getFromBinLogPacket' (getUpdateRowEvent fd tme) q'+ pure (Just (RowUpdateEvent tr tme e))+ | otherwise -> loop fd fref is+ | otherwise -> loop fd fref is++ track p fref = BinLogTracker <$> readIORef fref <*> (pure . fromIntegral . blLogPos) p++-- | Get latest master's binlog filename and position.+--+getLastBinLogTracker :: MySQLConn -> IO (Maybe BinLogTracker)+getLastBinLogTracker conn = do+ (_, is) <- query_ conn "SHOW MASTER STATUS"+ row <- Stream.read is+ Stream.skipToEof is+ case row of+ Just (MySQLText fn : MySQLInt64U pos : _) -> return . Just $ BinLogTracker (encodeUtf8 fn) (fromIntegral pos)+ _ -> return Nothing++-- | Return True if binlog_checksum = CRC32. Only for MySQL > 5.6+--+isCheckSumEnabled :: MySQLConn -> IO Bool+isCheckSumEnabled conn = do+ (_, is) <- query_ conn "SHOW GLOBAL VARIABLES LIKE 'binlog_checksum'"+ row <- Stream.read is+ Stream.skipToEof is+ case row of+ Just [_, MySQLText "CRC32"] -> return True+ _ -> return False++-- | Return True if rpl_semi_sync_master_enabled = ON. Only for MySQL > 5.5+--+isSemiSyncEnabled :: MySQLConn -> IO Bool+isSemiSyncEnabled conn = do+ (_, is) <- query_ conn "SHOW VARIABLES LIKE 'rpl_semi_sync_master_enabled'"+ row <- Stream.read is+ Stream.skipToEof is+ case row of+ Just [_, MySQLText "ON"] -> return True+ _ -> return False
+ Database/MySQL/BinLogProtocol/BinLogEvent.hs view
@@ -0,0 +1,292 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module : Database.MySQL.BinLogProtocol.BinLogEvent+Description : Binlog event+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++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.Get+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 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++--------------------------------------------------------------------------------+-- | binlog tyoe+--+data BinLogEventType+ = BINLOG_UNKNOWN_EVENT+ | BINLOG_START_EVENT_V3+ | BINLOG_QUERY_EVENT+ | BINLOG_STOP_EVENT+ | BINLOG_ROTATE_EVENT+ | BINLOG_INTVAR_EVENT+ | BINLOG_LOAD_EVENT+ | BINLOG_SLAVE_EVENT+ | BINLOG_CREATE_FILE_EVENT+ | BINLOG_APPEND_BLOCK_EVENT+ | BINLOG_EXEC_LOAD_EVENT+ | BINLOG_DELETE_FILE_EVENT+ | BINLOG_NEW_LOAD_EVENT+ | BINLOG_RAND_EVENT+ | BINLOG_USER_VAR_EVENT+ | BINLOG_FORMAT_DESCRIPTION_EVENT+ | BINLOG_XID_EVENT+ | BINLOG_BEGIN_LOAD_QUERY_EVENT+ | BINLOG_EXECUTE_LOAD_QUERY_EVENT+ | BINLOG_TABLE_MAP_EVENT+ | BINLOG_WRITE_ROWS_EVENTv0+ | BINLOG_UPDATE_ROWS_EVENTv0+ | BINLOG_DELETE_ROWS_EVENTv0+ | BINLOG_WRITE_ROWS_EVENTv1+ | BINLOG_UPDATE_ROWS_EVENTv1+ | BINLOG_DELETE_ROWS_EVENTv1+ | BINLOG_INCIDENT_EVENT+ | BINLOG_HEARTBEAT_EVENT+ | BINLOG_IGNORABLE_EVENT+ | BINLOG_ROWS_QUERY_EVENT+ | BINLOG_WRITE_ROWS_EVENTv2+ | BINLOG_UPDATE_ROWS_EVENTv2+ | BINLOG_DELETE_ROWS_EVENTv2+ | BINLOG_GTID_EVENT+ | BINLOG_ANONYMOUS_GTID_EVENT+ | BINLOG_PREVIOUS_GTIDS_EVENT+ 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+ , blSemiAck :: !Bool+ } deriving (Show, Eq)++putSemiAckResp :: Word32 -> ByteString -> Put+putSemiAckResp pos fn = put pos >> put fn++getBinLogPacket :: Bool -> Bool -> Get BinLogPacket+getBinLogPacket checksum semi = do+ _ <- getWord8 -- OK byte+ ack <- if semi+ then getWord8 >> (== 0x01) <$> getWord8+ 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)+ return (BinLogPacket ts typ sid size (fromIntegral pos) flgs body ack)++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)+ Partial _ -> throwIO DecodePacketPartial++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)+ Partial _ -> throwIO DecodePacketPartial++--------------------------------------------------------------------------------++data FormatDescription = FormatDescription+ { fdVersion :: !Word16+ , fdMySQLVersion :: !ByteString+ , fdCreateTime :: !Word32+ -- , eventHeaderLen :: !Word8 -- const 19+ , fdEventHeaderLenVector :: !ByteString -- ^ a array indexed by Binlog Event Type - 1+ -- to extract the length of the event specific header.+ } deriving (Show, Eq)++getFormatDescription :: Get FormatDescription+getFormatDescription = FormatDescription <$> getWord16le+ <*> getByteString 50+ <*> getWord32le+ <* getWord8+ <*> (L.toStrict <$> getRemainingLazyByteString)++eventHeaderLen :: FormatDescription -> BinLogEventType -> Word8+eventHeaderLen fd typ = B.unsafeIndex (fdEventHeaderLenVector fd) (fromEnum typ - 1)++data RotateEvent = RotateEvent+ { rPos :: !Word64, rFileName :: !ByteString } deriving (Show, Eq)++getRotateEvent :: Get RotateEvent+getRotateEvent = RotateEvent <$> getWord64le <*> getRemainingByteString++-- | This's query parser for statement based binlog's query event, it's actually+-- not used in row based binlog.+--+data QueryEvent = QueryEvent+ { qSlaveProxyId :: !Word32+ , qExecTime :: !Word32+ , qErrCode :: !Word16+ , qStatusVars :: !ByteString+ , qSchemaName :: !ByteString+ , qQuery :: !Query+ } deriving (Show, Eq)++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+ 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++data TableMapEvent = TableMapEvent+ { tmTableId :: !Word64+ , tmFlags :: !Word16+ , tmSchemaName :: !ByteString+ , tmTableName :: !ByteString+ , tmColumnCnt :: !Int+ , tmColumnType :: ![FieldType]+ , tmColumnMeta :: ![BinLogMeta]+ , tmNullMap :: !ByteString+ } deriving (Show, Eq)++getTableMapEvent :: FormatDescription -> Get TableMapEvent+getTableMapEvent 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)+ return (TableMapEvent tid flgs schema table cc typs metas nullmap)++data DeleteRowsEvent = DeleteRowsEvent+ { deleteTableId :: !Word64+ , deleteFlags :: !Word16+ -- , deleteExtraData :: !RowsEventExtraData+ , deleteColumnCnt :: !Int+ , deletePresentMap :: !BitMap+ , deleteRowData :: ![[BinLogValue]]+ } deriving (Show, Eq)++getDeleteRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> Get DeleteRowsEvent+getDeleteRowEvent fd tme typ = do+ let hlen = eventHeaderLen fd typ+ tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le+ flgs <- getWord16le+ when (typ == BINLOG_DELETE_ROWS_EVENTv2) $ do+ extraLen <- getWord16le+ void $ getByteString (fromIntegral extraLen - 2)+ colCnt <- getLenEncInt+ let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8+ pmap <- getPresentMap plen poffset+ DeleteRowsEvent tid flgs colCnt pmap <$> untilM (getBinLogRow (tmColumnMeta tme) pmap) isEmpty++data WriteRowsEvent = WriteRowsEvent+ { writeTableId :: !Word64+ , writeFlags :: !Word16+ -- , writeExtraData :: !RowsEventExtraData+ , writeColumnCnt :: !Int+ , writePresentMap :: !BitMap+ , writeRowData :: ![[BinLogValue]]+ } deriving (Show, Eq)++getWriteRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> Get WriteRowsEvent+getWriteRowEvent fd tme typ = do+ let hlen = eventHeaderLen fd typ+ tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le+ flgs <- getWord16le+ when (typ == BINLOG_WRITE_ROWS_EVENTv2) $ do+ extraLen <- getWord16le+ void $ getByteString (fromIntegral extraLen - 2)+ colCnt <- getLenEncInt+ let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8+ pmap <- getPresentMap plen poffset+ WriteRowsEvent tid flgs colCnt pmap <$> untilM (getBinLogRow (tmColumnMeta tme) pmap) isEmpty++data UpdateRowsEvent = UpdateRowsEvent+ { updateTableId :: !Word64+ , updateFlags :: !Word16+ -- , updateExtraData :: !RowsEventExtraData+ , updateColumnCnt :: !Int+ , updatePresentMap :: !(BitMap, BitMap)+ , updateRowData :: ![ ([BinLogValue], [BinLogValue]) ]+ } deriving (Show, Eq)++getUpdateRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> Get UpdateRowsEvent+getUpdateRowEvent fd tme typ = do+ let hlen = eventHeaderLen fd typ+ tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le+ flgs <- getWord16le+ when (typ == BINLOG_UPDATE_ROWS_EVENTv2) $ do+ extraLen <- getWord16le+ void $ getByteString (fromIntegral extraLen - 2)+ colCnt <- getLenEncInt+ let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8+ pmap <- getPresentMap plen poffset+ pmap' <- getPresentMap 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))+ pure (BitMap pmap')+
+ Database/MySQL/BinLogProtocol/BinLogMeta.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module : Database.MySQL.BinLogProtocol.BinLogMeta+Description : binlog protocol column meta+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++This module provide column meta decoder for binlog protocol.++There're certain type won't appear in binlog event, and some types are compressed into 'mySQLTypeString'+, please take python version as a reference: <https://github.com/noplay/python-mysql-replication>++You will not directly meet following 'FieldType' namely:++ * mySQLTypeDecimal+ * mySQLTypeNewdate+ * mySQLTypeEnum+ * mySQLTypeSet+ * mySQLTypeTinyBlob+ * mySQLTypeMediumBlOb+ * mySQLTypeLongBlob++-}++module Database.MySQL.BinLogProtocol.BinLogMeta where++import Control.Applicative+import Data.Binary.Get+import Data.Bits+import Data.Word+import Database.MySQL.Protocol.ColumnDef++-- | An intermedia date type for decoding row-based event's values.+--+data BinLogMeta+ = BINLOG_TYPE_TINY+ | BINLOG_TYPE_SHORT+ | BINLOG_TYPE_INT24+ | BINLOG_TYPE_LONG+ | BINLOG_TYPE_LONGLONG+ | BINLOG_TYPE_FLOAT !Word8 -- ^ size+ | BINLOG_TYPE_DOUBLE !Word8 -- ^ size+ | BINLOG_TYPE_BIT !Word16 !Word8 -- ^ bits, bytes+ | BINLOG_TYPE_TIMESTAMP+ | BINLOG_TYPE_DATETIME+ | BINLOG_TYPE_DATE+ | BINLOG_TYPE_TIME+ | BINLOG_TYPE_TIMESTAMP2 !Word8 -- ^ fsp+ | BINLOG_TYPE_DATETIME2 !Word8 -- ^ fsp+ | BINLOG_TYPE_TIME2 !Word8 -- ^ fsp+ | BINLOG_TYPE_YEAR+ | BINLOG_TYPE_NEWDECIMAL !Word8 !Word8 -- ^ precision, scale+ | BINLOG_TYPE_ENUM !Word8 -- ^ 1 or 2('Word8' or 'Word16'), enum index size+ | BINLOG_TYPE_SET !Word16 !Word8 -- ^ bitmap bits, bytes+ | BINLOG_TYPE_BLOB !Word8 -- ^ length size+ | BINLOG_TYPE_STRING !Word16 -- ^ meta length(if < 256, then length is 8bit,+ -- if > 256 then length is 16bit)+ | 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++ | t == mySQLTypeBit = do+ byte0 <- getWord8+ byte1 <- getWord8+ 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 == mySQLTypeString = do+ byte0 <- getWord8+ byte1 <- getWord8+ -- http://bugs.mysql.com/37426+ if byte0 > 0+ then if (byte0 .&. 0x30) /= 0x30+ then if FieldType (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+ 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'+ 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
+ Database/MySQL/BinLogProtocol/BinLogValue.hs view
@@ -0,0 +1,323 @@+{-|+Module : Database.MySQL.BinLogProtocol.BinLogValue+Description : binlog protocol+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++Binlog protocol++-}+++module Database.MySQL.BinLogProtocol.BinLogValue where++import Control.Applicative+import Data.Binary.Get+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 type for representing binlog values.+--+-- This data type DOES NOT try to parse binlog values into detailed haskell values,+-- because you may not want to waste performance in situations like database middleware.+--+-- Due to the lack of signedness infomation in binlog meta, we cannot distinguish,+-- for example, between unsigned tiny 255 and tiny -1, so we use int to present+-- @TINY,SHORT,INT,LONG@. If you have unsigned columns, use 'fromIntegral' to convert it+-- to word to get real unsigned value back, for example, @fromIntegral (-1 :: Int) == 255 :: Word@+--+-- For above reason, we use 'Int24' to present MySQL's @INT24@ type, you can get back the+-- unsigned value using @word24@ package's 'Word24' type.+--+-- 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+-- and blob types.+--+-- The @SET@ and @ENUM@ values are presented by their index's value and bitmap respectively,+-- if you need get the string value back, you have to perform a 'DESC tablename' to get the+-- set or enum table.+--+data BinLogValue+ = BinLogTiny !Int8+ | BinLogShort !Int16+ | BinLogInt24 !Int24+ | BinLogLong !Int32+ | BinLogLongLong !Int64+ | BinLogFloat !Float+ | BinLogDouble !Double+ | BinLogBit !Word64 -- ^ a 64bit bitmap.+ | BinLogTimeStamp !Word32 -- ^ a utc timestamp, note 0 doesn't mean @1970-01-01 00:00:00@,+ -- because mysql choose 0 to present '0000-00-00 00:00:00'+ | BinLogTimeStamp2 !Word32 !Word32 -- ^ like 'BinLogTimeStamp' with an addtional microseconds field.+ | BinLogDateTime !Word16 !Word8 !Word8 !Word8 !Word8 !Word8 -- ^ YYYY MM DD hh mm ss+ | BinLogDateTime2 !Word16 !Word8 !Word8 !Word8 !Word8 !Word8 !Word32 -- ^ YYYY MM DD hh mm ss microsecond+ | BinLogDate !Word16 !Word8 !Word8 -- ^ YYYY MM DD+ | BinLogTime !Word8 !Word16 !Word8 !Word8 -- ^ sign(1= non-negative, 0= negative) hh mm ss+ | BinLogTime2 !Word8 !Word16 !Word8 !Word8 !Word32 -- ^ sign(1= non-negative, 0= negative) hh mm ss microsecond+ | BinLogYear !Word16 -- ^ year value, 0 stand for '0000'+ | 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+ | 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++-- ^ a integer in @YYYYMMDD@ format, for example:+-- 99991231 stand for @9999-12-31@+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 -- big-endian here!+ ms <- fromIntegral <$> getMicroSecond 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+ 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))++-- BINLOG_TYPE_DATETIME2(big endian)+--+-- 1 bit sign (used when on disk)+-- 17 bits year * 13 + month (year 0-9999, month 0-12)+-- 5 bits day (0-31)+-- 5 bits hour (0-23)+-- 6 bits minute (0-59)+-- 6 bits second (0-59)+-- (5 bytes in total)+--+-- fractional-seconds storage (size depends on meta)+--+getBinLogField (BINLOG_TYPE_DATETIME2 fsp) = do+ iPart <- getWord40be+ let yyyymm = iPart `shiftR` 22 .&. 0x01FFFF -- 0b011111111111111111+ (yyyy, mm) = yyyymm `quotRem` 13+ yyyy' = fromIntegral yyyy+ mm' = fromIntegral mm+ dd = fromIntegral $ iPart `shiftR` 17 .&. 0x1F -- 0b00011111+ h = fromIntegral $ iPart `shiftR` 12 .&. 0x1F -- 0b00011111+ m = fromIntegral $ iPart `shiftR` 6 .&. 0x3F -- 0b00111111+ s = fromIntegral $ iPart .&. 0x3F -- 0b00111111+ ms <- fromIntegral <$> getMicroSecond 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+ 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)))++-- BINLOG_TYPE_TIME2(big endian)+--+-- 1 bit sign (1= non-negative, 0= negative)+-- 1 bit unused (Reserved for wider hour range, e.g. for intervals)+-- 10 bit hour (0-836)+-- 6 bit minute (0-59)+-- 6 bit second (0-59)+-- (3 bytes in total)+--+-- fractional-seconds storage (size depends on meta)+--+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 -- 0b0000001111111111+ m = fromIntegral (iPart' `shiftR` 6) .&. 0x3F -- 0b00111111+ s = fromIntegral iPart' .&. 0x3F -- 0b00111111+ 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)++-- Decimal representation in binlog seems to be as follows:+--+-- 1st bit - sign such that set == +, unset == -+-- every 4 bytes represent 9 digits in big-endian order.+--+-- 80 00 00 05 1b 38 b0 60 00 means:+--+-- 0x80 - positive+-- 0x00000005 - 5+-- 0x1b38b060 - 456700000+-- 0x00 - 0+--+-- 54567000000 / 10^{10} = 5.4567+--+-- 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+ 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++--------------------------------------------------------------------------------+-- | BinLog row decoder+--+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'
+ Database/MySQL/Connection.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE CPP #-}++{-|+Module : Database.MySQL.Connection+Description : Connection managment+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++This is an internal module, the 'MySQLConn' type should not directly acessed to user.++-}++module Database.MySQL.Connection where++import Control.Exception (Exception, bracketOnError,+ throwIO)+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.Word+import Database.MySQL.Protocol.Auth+import Database.MySQL.Protocol.Command+import Database.MySQL.Protocol.Packet+import Network.Socket (HostName, PortNumber)+import qualified Network.Socket as N+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Stream+import qualified System.IO.Streams.Binary as Binary+import qualified System.IO.Streams.TCP as TCP+import qualified System.IO.Streams.TLS as TLS+import qualified Data.TLSSetting as TLS+import qualified Network.TLS as TLS++--------------------------------------------------------------------------------++data MySQLConn = MySQLConn {+ mysqlRead :: {-# UNPACK #-} !(InputStream Packet)+ , mysqlWrite :: {-# UNPACK #-} !(OutputStream Packet)+ , mysqlCloseSocket :: IO ()+ , isConsumed :: {-# UNPACK #-} !(IORef Bool)+ }++-- | Everything you need to establish a MySQL connection.+--+-- You may want some helpers in "System.IO.Streams.TLS" to setup TLS connection.+--+data ConnectInfo = ConnectInfo+ { ciHost :: HostName+ , ciPort :: PortNumber+ , ciDatabase :: ByteString+ , ciUser :: ByteString+ , ciPassword :: ByteString+ , ciTLSInfo :: Maybe (TLS.ClientParams, String) -- ^ If 'TLS.ClientParams' and subject name are provided,+ -- TLS connection will be used.+ } deriving Show++-- | A simple 'ConnectInfo' targeting localhost with @user=root@ and empty password.+--+defaultConnectInfo :: ConnectInfo+defaultConnectInfo = ConnectInfo "127.0.0.1" 3306 "" "root" "" Nothing++--------------------------------------------------------------------------------++-- | Socket buffer size.+--+-- maybe exposed to 'ConnectInfo' laster?+--+bUFSIZE :: Int+bUFSIZE = 16384++-- | Establish a MySQL connection.+--+connect :: ConnectInfo -> IO 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 ci@(ConnectInfo host port _ _ _ tls) =+ case tls of+ Nothing ->+ bracketOnError (TCP.connectWithBufferSize host port bUFSIZE)+ (\(_, _, sock) -> N.close sock) $ \ (is, os, sock) -> do+ is' <- decodeInputStream is+ os' <- Binary.encodeOutputStream os+ p <- readPacket is'+ greet <- decodeFromPacket p+ let auth = mkAuth ci greet+ Stream.write (Just (encodeToPacket 1 auth)) os'+ q <- readPacket is'+ if isOK q+ then do+ consumed <- newIORef True+ let conn = (MySQLConn is' os' (N.close sock) consumed)+ return (greet, conn)+ else Stream.write Nothing os' >> decodeFromPacket q >>= throwIO . ERRException+ Just (cp, sname) ->+ bracketOnError (TLS.connect cp (Just sname) host port)+ (\(_, _, ctx) -> TLS.close ctx) $ \ (is, os, ctx) -> do+ is' <- decodeInputStream is+ os' <- Binary.encodeOutputStream os+ p <- readPacket is'+ greet <- decodeFromPacket p+ let auth = mkAuth ci greet+ Stream.write (Just (encodeToPacket 1 auth)) os'+ q <- readPacket is'+ if isOK q+ then do+ consumed <- newIORef True+ let conn = (MySQLConn is' os' (TLS.close ctx) consumed)+ return (greet, conn)+ else Stream.write Nothing os' >> decodeFromPacket q >>= throwIO . ERRException+ where+ mkAuth :: ConnectInfo -> Greeting -> Auth+ mkAuth (ConnectInfo _ _ db user pass _) greet =+ let salt = greetingSalt1 greet `B.append` greetingSalt2 greet+ scambleBuf = scramble salt pass+ in Auth clientCap clientMaxPacketSize clientCharset user scambleBuf db++ scramble :: ByteString -> ByteString -> ByteString+ scramble salt pass+ | B.null pass = B.empty+ | otherwise = B.pack (B.zipWith xor sha1pass withSalt)+ 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++ 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 = B.length bs'+ if l >= k+ then do+ let (a, rest) = B.splitAt 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 _ os closeSocket _) = do+ Stream.write Nothing os+ closeSocket++-- | Send a 'COM_PING'.+--+ping :: MySQLConn -> IO OK+ping = flip command COM_PING++--------------------------------------------------------------------------------+-- helpers++-- | Send a 'Command' which don't return a resultSet.+--+command :: MySQLConn -> Command -> IO OK+command conn@(MySQLConn is os _ _) cmd = do+ guardUnconsumed conn+ writeCommand cmd os+ p <- readPacket is+ if | isERR p -> decodeFromPacket p >>= throwIO . ERRException+ | isOK p -> decodeFromPacket p+ | otherwise -> throwIO (UnexpectedPacket p)+{-# INLINE command #-}++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'+ )+{-# INLINE readPacket #-}++writeCommand :: Command -> OutputStream Packet -> IO ()+writeCommand a = let bs = Binary.runPut (Binary.put a) in+ go (fromIntegral (L.length bs)) 0 bs+ where+ go len seqN bs =+ if len < 16777215+ then Stream.write (Just (Packet len seqN bs))+ else go (len - 16777215) (seqN + 1) (L.drop 16777215 bs)+{-# INLINE writeCommand #-}++guardUnconsumed :: MySQLConn -> IO ()+guardUnconsumed (MySQLConn _ _ _ consumed) = do+ c <- readIORef consumed+ unless c (throwIO UnconsumedResultSet)+{-# INLINE guardUnconsumed #-}++writeIORef' :: IORef a -> a -> IO ()+writeIORef' ref x = x `seq` writeIORef ref x+{-# INLINE writeIORef' #-}++--------------------------------------------------------------------------------+-- default Capability Flags++#define CLIENT_LONG_PASSWORD 0x00000001+#define CLIENT_FOUND_ROWS 0x00000002+#define CLIENT_LONG_FLAG 0x00000004+#define CLIENT_CONNECT_WITH_DB 0x00000008+#define CLIENT_NO_SCHEMA 0x00000010+#define CLIENT_COMPRESS 0x00000020+#define CLIENT_ODBC 0x00000040+#define CLIENT_LOCAL_FILES 0x00000080+#define CLIENT_IGNORE_SPACE 0x00000100+#define CLIENT_PROTOCOL_41 0x00000200+#define CLIENT_INTERACTIVE 0x00000400+#define CLIENT_SSL 0x00000800+#define CLIENT_IGNORE_SIGPIPE 0x00001000+#define CLIENT_TRANSACTIONS 0x00002000+#define CLIENT_RESERVED 0x00004000+#define CLIENT_SECURE_CONNECTION 0x00008000+#define CLIENT_MULTI_STATEMENTS 0x00010000+#define CLIENT_MULTI_RESULTS 0x00020000+#define CLIENT_PS_MULTI_RESULTS 0x00040000+#define CLIENT_PLUGIN_AUTH 0x00080000+#define CLIENT_CONNECT_ATTRS 0x00100000+#define CLIENT_PLUGIN_AUTH_LENENC_CLIENT_DATA 0x00200000++clientCap :: Word32+clientCap = CLIENT_LONG_PASSWORD+ .|. CLIENT_LONG_FLAG+ .|. CLIENT_CONNECT_WITH_DB+ .|. CLIENT_IGNORE_SPACE+ .|. CLIENT_PROTOCOL_41+ .|. CLIENT_TRANSACTIONS+ .|. CLIENT_SECURE_CONNECTION++clientMaxPacketSize :: Word32+clientMaxPacketSize = 0x00ffffff :: Word32++-- | Always use @utf8_general_ci@ when connecting mysql server,+-- since this will simplify string decoding.+clientCharset :: Word8+clientCharset = 0x21 :: Word8++--------------------------------------------------------------------------------+-- Exceptions++data NetworkException = NetworkException deriving (Typeable, Show)+instance Exception NetworkException++data UnconsumedResultSet = UnconsumedResultSet deriving (Typeable, Show)+instance Exception UnconsumedResultSet++data ERRException = ERRException ERR deriving (Typeable, Show)+instance Exception ERRException++data UnexpectedPacket = UnexpectedPacket Packet deriving (Typeable, Show)+instance Exception UnexpectedPacket
+ Database/MySQL/Protocol/Auth.hs view
@@ -0,0 +1,103 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module : Database.MySQL.Protocol.Auth+Description : MySQL field type+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++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.Put+import qualified Data.ByteString as B+import Data.ByteString.Char8 as BC+import Database.MySQL.Protocol.Packet++--------------------------------------------------------------------------------+-- Authentications++data Greeting = Greeting+ { greetingProtocol :: !Word8+ , greetingVersion :: !B.ByteString+ , greetingTid :: !Word32+ , greetingSalt1 :: !B.ByteString+ , greetingCaps :: !Word16+ , greetingLang :: !Word8+ , greetingStatus :: !Word16+ , greetingSalt2 :: !B.ByteString+ } deriving (Show, Eq)++putGreeting :: Greeting -> Put+putGreeting (Greeting p v t s1 c l st s2) = do+ putWord8 p+ putByteString v+ putWord8 0x00+ putWord32le t+ putByteString s1+ putWord16le c+ putWord8 l+ putWord16le st+ replicateM_ 13 (putWord8 0x00)+ putByteString s2++getGreeting :: Get Greeting+getGreeting = Greeting+ <$> getWord8+ <*> getByteStringNul+ <*> getWord32le+ <*> getByteStringNul+ <*> getWord16le+ <*> getWord8+ <*> getWord16le+ <* skip 13+ <*> getByteStringNul+ <* getByteStringNul++instance Binary Greeting where+ get = getGreeting+ put = putGreeting++data Auth = Auth+ { authCaps :: !Word32+ , authMaxPacket :: !Word32+ , authCharset :: !Word8+ , authName :: !ByteString+ , authPassword :: !ByteString+ , authSchema :: !ByteString+ } deriving (Show, Eq)++getAuth :: Get Auth+getAuth = do+ a <- getWord32le+ m <- getWord32le+ c <- getWord8+ skip 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
+ Database/MySQL/Protocol/ColumnDef.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module : Database.MySQL.Protocol.ColumnDef+Description : MySQL field type+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++Column definition(aka. field type).++-}++module Database.MySQL.Protocol.ColumnDef where++import Control.Applicative+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits ((.&.))+import Data.ByteString (ByteString)+import Database.MySQL.Protocol.Packet++--------------------------------------------------------------------------------+-- Resultset++-- | 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.+ } deriving (Show, Eq)++getField :: Get ColumnDef+getField = ColumnDef+ <$> (skip 4 -- const "def"+ *> getLenEncBytes) -- db+ <*> getLenEncBytes -- table+ <*> getLenEncBytes -- origTable+ <*> getLenEncBytes -- name+ <*> getLenEncBytes -- origName+ <* skip 1 -- const 0x0c+ <*> getWord16le -- charset+ <*> getWord32le -- length+ <*> getFieldType -- type+ <*> getWord16le -- flags+ <*> getWord8 -- decimals+ <* skip 2 -- const 0x00 0x00++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++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++putFieldType :: FieldType -> Put+putFieldType (FieldType t) = putWord8 t++instance Binary FieldType where+ get = getFieldType+ {-# INLINE get #-}+ put = putFieldType+ {-# INLINE put #-}++--------------------------------------------------------------------------------+-- Field flags++#define NOT_NULL_FLAG 1+#define PRI_KEY_FLAG 2+#define UNIQUE_KEY_FLAG 4+#define MULT_KEY_FLAG 8+#define BLOB_FLAG 16+#define UNSIGNED_FLAG 32+#define ZEROFILL_FLAG 64+#define BINARY_FLAG 128+#define ENUM_FLAG 256+#define AUTO_INCREMENT_FLAG 512+#define TIMESTAMP_FLAG 1024+#define SET_FLAG 2048+#define NO_DEFAULT_VALUE_FLAG 4096+#define PART_KEY_FLAG 16384+#define NUM_FLAG 32768++flagNotNull, flagPrimaryKey, flagUniqueKey, flagMultipleKey, flagBlob, flagUnsigned, flagZeroFill :: Word16 -> Bool+flagBinary, flagEnum, flagAutoIncrement, flagTimeStamp, flagSet, flagNoDefaultValue, flagPartKey, flagNumeric :: Word16 -> Bool+flagNotNull flags = flags .&. NOT_NULL_FLAG == NOT_NULL_FLAG+flagPrimaryKey flags = flags .&. PRI_KEY_FLAG == PRI_KEY_FLAG+flagUniqueKey flags = flags .&. UNIQUE_KEY_FLAG == UNIQUE_KEY_FLAG+flagMultipleKey flags = flags .&. MULT_KEY_FLAG == MULT_KEY_FLAG+flagBlob flags = flags .&. BLOB_FLAG == BLOB_FLAG+flagUnsigned flags = flags .&. UNSIGNED_FLAG == UNSIGNED_FLAG+flagZeroFill flags = flags .&. ZEROFILL_FLAG == ZEROFILL_FLAG+flagBinary flags = flags .&. BINARY_FLAG == BINARY_FLAG+flagEnum flags = flags .&. ENUM_FLAG == ENUM_FLAG+flagAutoIncrement flags = flags .&. AUTO_INCREMENT_FLAG == AUTO_INCREMENT_FLAG+flagTimeStamp flags = flags .&. TIMESTAMP_FLAG == TIMESTAMP_FLAG+flagSet flags = flags .&. SET_FLAG == SET_FLAG+flagNoDefaultValue flags = flags .&. NO_DEFAULT_VALUE_FLAG == NO_DEFAULT_VALUE_FLAG+flagPartKey flags = flags .&. PART_KEY_FLAG == PART_KEY_FLAG+flagNumeric flags = flags .&. NUM_FLAG == NUM_FLAG
+ Database/MySQL/Protocol/Command.hs view
@@ -0,0 +1,129 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module : Database.MySQL.Protocol.Command+Description : MySQL commands+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++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.Put+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import Database.MySQL.Protocol.MySQLValue+import Database.MySQL.Protocol.Packet++--------------------------------------------------------------------------------+-- Commands++type StmtID = Word32++-- | All support MySQL commands.+--+data Command+ = COM_QUIT -- ^ 0x01+ | COM_INIT_DB !ByteString -- ^ 0x02+ | COM_QUERY !L.ByteString -- ^ 0x03+ | COM_PING -- ^ 0x0E+ | COM_BINLOG_DUMP !Word32 !Word16 !Word32 !ByteString -- ^ 0x12+ -- binlog-pos, flags(0x01), server-id, binlog-filename+ | COM_REGISTER_SLAVE !Word32 !ByteString !ByteString !ByteString !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_EXECUTE !StmtID ![MySQLValue] -- ^ 0x17 stmtId, params+ | COM_STMT_CLOSE !StmtID -- ^ 0x19 stmtId+ | COM_STMT_RESET !StmtID -- ^ 0x1A stmtId+ | COM_UNSUPPORTED+ deriving (Show, Eq)++getCommand :: Get Command+getCommand = do+ cmdId <- getWord8+ case cmdId of+ 0x01 -> pure COM_QUIT+ 0x02 -> COM_INIT_DB <$> getRemainingByteString+ 0x03 -> COM_QUERY <$> getRemainingLazyByteString+ 0x0E -> pure COM_PING+ 0x12 -> COM_BINLOG_DUMP+ <$> getWord32le <*> getWord16le <*> getWord32le <*> getRemainingByteString+ 0x15 -> COM_REGISTER_SLAVE+ <$> getWord32le <*> getLenEncBytes <*> getLenEncBytes <*> getLenEncBytes+ <*> getWord16le <*> getWord32le <*> getWord32le+ 0x16 -> COM_STMT_PREPARE <$> getRemainingLazyByteString+ 0x17 -> fail "Database.MySQL.Protocol.Command: decode COM_STMT_EXECUTE need column number"+ 0x19 -> COM_STMT_CLOSE <$> getWord32le+ 0x1A -> COM_STMT_RESET <$> getWord32le+ _ -> pure COM_UNSUPPORTED++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) = do+ putWord8 0x17+ putWord32le stid+ putWord8 0x00 -- we only use @CURSOR_TYPE_NO_CURSOR@ here+ putWord32le 1 -- const 1+ unless (null params) $ do+ putByteString . fromBitMap $ makeNullMap params+ putWord8 0x01 -- always use new-params-bound-flag+ mapM_ putParamMySQLType params+ forM_ params putBinaryField++putCommand (COM_STMT_CLOSE stid) = putWord8 0x19 >> putWord32le stid+putCommand (COM_STMT_RESET stid) = putWord8 0x1A >> putWord32le stid+putCommand _ = fail "unsupported command"++instance Binary Command where+ get = getCommand+ put = putCommand++--------------------------------------------------------------------------------+-- Prepared statment related++-- | call 'isOK' with this packet return true+data StmtPrepareOK = StmtPrepareOK+ { stmtId :: !Word32+ , stmtColumnCnt :: !Int+ , stmtParamCnt :: !Int+ , stmtWarnCnt :: !Int+ } deriving (Show, Eq)++getStmtPrepareOK :: Get StmtPrepareOK+getStmtPrepareOK = do+ _ <- getWord8 -- OK byte+ stmtid <- getWord32le+ cc <- fromIntegral <$> getWord16le+ pc <- fromIntegral <$> getWord16le+ _ <- getWord8 -- reserved+ wc <- fromIntegral <$> getWord16le+ return (StmtPrepareOK stmtid cc pc wc)
+ Database/MySQL/Protocol/Escape.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE BangPatterns #-}++{-|+Module : Database.MySQL.Protocol.Escape+Description : Pure haskell mysql escape+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++This module provide escape machinery for bytes and text types.++reference: <http://dev.mysql.com/doc/refman/5.7/en/string-literals.html>++ * 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.++-}++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.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)
+ Database/MySQL/Protocol/MySQLValue.hs view
@@ -0,0 +1,528 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module : Database.MySQL.Protocol.MySQLValue+Description : Text and binary protocol+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++Core text and binary row decoder/encoder machinery.++-}++module Database.MySQL.Protocol.MySQLValue where++import qualified Blaze.Text as Textual+import Control.Applicative+import Control.Monad+import Data.Binary.Get+import Data.Binary.Put+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.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.Word+import Database.MySQL.Protocol.ColumnDef+import Database.MySQL.Protocol.Escape+import Database.MySQL.Protocol.Packet+import GHC.Generics (Generic)++--------------------------------------------------------------------------------+-- | Data type mapping between MySQL values and haskell values.+--+-- There're some subtle differences between MySQL values and haskell values:+--+-- 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.+--+-- * 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+-- 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 <http://dev.mysql.com/doc/refman/5.7/en/time-zone-support.html>+--+-- So we use 'LocalTime' to present both @DATETIME@ and @TIMESTAMP@, but the local here is different.+--+-- 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.+--+-- 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+ | MySQLNull+ deriving (Show, Eq, Generic)++-- | Decide if usigned bit(0x80) and 'FieldType' 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++--------------------------------------------------------------------------------+-- | 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 B.null bs+ then pure MySQLNull+ else if bs `BC.index` 0 == '-'+ 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 = do len <- getLenEncInt+ if len == 0 then pure MySQLNull+ else MySQLBit <$> getBits len++ | 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 typ con parser = do+ bs <- getLenEncBytes+ if B.null bs+ then return MySQLNull+ else case parser bs of+ Just v -> return (con v)+ Nothing -> fail $ "Database.MySQL.Protocol.MySQLValue: parsing " ++ show typ ++ " failed, \+ \input: " ++ BC.unpack bs+ {-# INLINE feedLenEncBytes #-}++--------------------------------------------------------------------------------+-- | 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))+ -- 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 '\''+putTextField MySQLNull = putBuilder "NULL"++putInQuotes :: Put -> Put+putInQuotes p = putCharUtf8 '\'' >> p >> putCharUtf8 '\''+{-# INLINE putInQuotes #-}++--------------------------------------------------------------------------------+-- | Text row decoder+getTextRow :: [ColumnDef] -> Get [MySQLValue]+getTextRow fs = forM fs $ \ f -> do+ p <- lookAhead getWord8+ if p == 0xFB+ then getWord8 >> return MySQLNull+ else getTextField f+{-# INLINE getTextRow #-}++--------------------------------------------------------------------------------+-- | 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+ case n of+ 0 -> pure $ MySQLTimeStamp (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0))+ 4 -> do+ d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+ pure $ MySQLTimeStamp (LocalTime d (TimeOfDay 0 0 0))+ 7 -> do+ d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+ td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond4+ pure $ MySQLTimeStamp (LocalTime d td)+ 11 -> do+ d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+ td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond8+ pure $ MySQLTimeStamp (LocalTime d td)+ _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong TIMESTAMP length"+ | t == mySQLTypeDateTime+ || t == mySQLTypeDateTime2 = do+ n <- getLenEncInt+ case n of+ 0 -> pure $ MySQLDateTime (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0))+ 4 -> do+ d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+ pure $ MySQLDateTime (LocalTime d (TimeOfDay 0 0 0))+ 7 -> do+ d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+ td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond4+ pure $ MySQLDateTime (LocalTime d td)+ 11 -> do+ d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+ td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond8+ pure $ MySQLDateTime (LocalTime d td)+ _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATETIME length"++ | t == mySQLTypeDate+ || t == mySQLTypeNewDate = do+ n <- getLenEncInt+ case n of+ 0 -> pure $ MySQLDate (fromGregorian 0 0 0)+ 4 -> MySQLDate <$> (fromGregorian <$> getYear <*> getInt8' <*> getInt8')+ _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATE length"++ | t == mySQLTypeTime+ || t == mySQLTypeTime2 = do+ n <- getLenEncInt+ 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)++ 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)+ _ -> 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 = do len <- getLenEncInt+ if len == 0 then pure MySQLNull+ else MySQLBit <$> getBits len+ | 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+ pure $! (realToFrac s + realToFrac ms / 1000000 :: Pico)++ 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+ {-# INLINE feedLenEncBytes #-}++-- | convert a bit sequence to 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+ | 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+ | otherwise -> fail $ "Database.MySQL.Protocol.MySQLValue: \+ \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+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+ -- 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)++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+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++--------------------------------------------------------------------------------+-- | Binary row decoder+--+-- MySQL use a special null bitmap without offset = 2 here.+--+getBinaryRow :: [ColumnDef] -> Int -> Get [MySQLValue]+getBinaryRow fields flen = do+ _ <- getWord8 -- 0x00+ let maplen = (flen + 7 + 2) `shiftR` 3+ nullmap <- getByteString maplen+ go fields nullmap 0+ where+ go :: [ColumnDef] -> ByteString -> Int -> Get [MySQLValue]+ go [] _ _ = pure []+ go (f:fs) nullmap pos = do+ r <- if isNull nullmap pos+ then return MySQLNull+ else getBinaryField f+ let pos' = pos + 1+ rest <- pos' `seq` go fs nullmap pos'+ return (r `seq` (r : rest))++ isNull nullmap pos = -- This 'isNull' is special for offset = 2+ let (i, j) = (pos + 2) `quotRem` 8+ in (nullmap `B.unsafeIndex` i) `testBit` j+ {-# INLINE isNull #-}+{-# INLINE getBinaryRow #-}++-- | Use 'ByteString' to present a bitmap.+--+-- When used for represent bits values, the underlining 'ByteString' follows:+--+-- * byteString: head -> tail+-- * bit: high bit -> low bit+--+-- When used as a null-map/present-map, every bit inside a byte+-- is mapped to a column, the mapping order is following:+--+-- * byteString: head -> tail+-- * column: left -> right+--+-- We don't use 'Int64' here because there maybe more than 64 columns.+--+newtype BitMap = BitMap { fromBitMap :: ByteString } deriving (Eq, Show)++-- | test if a column is set+--+-- The number counts from left to right.+--+isColumnSet :: BitMap -> Int -> Bool+isColumnSet (BitMap bitmap) pos =+ let (i, j) = pos `quotRem` 8+ in (bitmap `B.unsafeIndex` i) `testBit` j+{-# INLINE isColumnSet #-}++-- | make a nullmap for params without offset.+--+makeNullMap :: [MySQLValue] -> BitMap+makeNullMap values = BitMap . B.pack $ go values 0x00 0+ where+ go :: [MySQLValue] -> Word8 -> Int -> [Word8]+ go [] byte 8 = [byte]+ go vs byte 8 = byte : go vs 0x00 0+ go [] byte _ = [byte]+ go (MySQLNull:vs) byte pos = let pos' = pos + 1+ byte' = byte .|. bit pos+ in pos' `seq` byte' `seq` go vs byte' pos'+ go (_ :vs) byte pos = let pos' = pos + 1 in pos' `seq` go vs byte pos'++--------------------------------------------------------------------------------+-- TODO: add helpers to parse mySQLTypeGEOMETRY+-- reference: https://github.com/felixge/node-mysql/blob/master/lib/protocol/Parser.js
+ Database/MySQL/Protocol/Packet.hs view
@@ -0,0 +1,294 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module : Database.MySQL.Protocol.Packet+Description : MySQL packet type+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++MySQL packet decoder&encoder, and varities utility.++-}++module Database.MySQL.Protocol.Packet where++import Control.Applicative+import Control.Exception (Exception (..), throwIO)+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+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.Typeable+import Data.Word.Word24++--------------------------------------------------------------------------------+-- | MySQL packet type+--+data Packet = Packet+ { pLen :: !Int+ , 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)+ return (Packet len seqN body)+{-# INLINE getPacket #-}++instance Binary Packet where+ put = putPacket+ {-# INLINE put #-}+ get = getPacket+ {-# INLINE get #-}++isERR :: Packet -> Bool+isERR p = L.index (pBody p) 0 == 0xFF+{-# INLINE isERR #-}++isOK :: Packet -> Bool+isOK p = L.index (pBody p) 0 == 0x00+{-# INLINE isOK #-}++isEOF :: Packet -> Bool+isEOF p = L.index (pBody p) 0 == 0xFE+{-# INLINE isEOF #-}++-- | Decoding packet inside IO, throw 'DecodePacketException' 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 (Packet _ _ body) = case pushEndOfInput $ pushChunks (runGetIncremental get) body of+ Done _ _ r -> return r+ Fail buf offset errmsg -> throwIO (DecodePacketFailed buf offset errmsg)+ Partial _ -> throwIO DecodePacketPartial+{-# INLINE decodeFromPacket #-}++getFromPacket :: Get a -> Packet -> IO a+getFromPacket g (Packet _ _ body) = case pushEndOfInput $ pushChunks (runGetIncremental g) body of+ Done _ _ r -> return r+ Fail buf offset errmsg -> throwIO (DecodePacketFailed buf offset errmsg)+ Partial _ -> throwIO DecodePacketPartial+{-# INLINE getFromPacket #-}++data DecodePacketException+ = DecodePacketFailed ByteString ByteOffset String+ | DecodePacketPartial+ deriving (Typeable, Show)+instance Exception DecodePacketException++encodeToPacket :: Binary a => Word8 -> a -> Packet+encodeToPacket seqN payload =+ let s = encode payload+ l = L.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+-- 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 <$> getLenEncInt+ <*> getLenEncInt+ <*> getWord16le+ <*> getWord16le++putOK :: OK -> Put+putOK (OK row lid stat wcnt) = do+ putWord8 0x00+ putLenEncInt row+ putLenEncInt lid+ putWord16le stat+ putWord16le wcnt++instance Binary OK where+ get = getOK+ {-# INLINE get #-}+ put = putOK+ {-# INLINE put #-}++data ERR = ERR+ { errCode :: !Word16+ , errState :: !ByteString+ , errMsg :: !ByteString+ } deriving (Show, Eq)++getERR :: Get ERR+getERR = ERR <$ skip 1+ <*> getWord16le+ <* skip 1+ <*> getByteString 5+ <*> getRemainingByteString++putERR :: ERR -> Put+putERR (ERR code stat msg) = do+ putWord8 0xFF+ putWord16le code+ putWord8 35 -- '#'+ putByteString stat+ putByteString msg++instance Binary ERR where+ get = getERR+ {-# INLINE get #-}+ put = putERR+ {-# INLINE put #-}++data EOF = EOF+ { eofWarningCnt :: !Word16+ , eofStatus :: !Word16+ } deriving (Show, Eq)++getEOF :: Get EOF+getEOF = EOF <$> getWord16le+ <*> getWord16le++putEOF :: EOF -> Put+putEOF (EOF wcnt stat) = do+ putWord8 0xFE+ putWord16le wcnt+ putWord16le stat++instance Binary EOF where+ get = getEOF+ {-# INLINE get #-}+ put = putEOF+ {-# INLINE put #-}++--------------------------------------------------------------------------------+-- Helpers++getByteStringNul :: Get ByteString+getByteStringNul = L.toStrict <$> getLazyByteStringNul+{-# INLINE getByteStringNul #-}++getRemainingByteString :: Get ByteString+getRemainingByteString = L.toStrict <$> getRemainingLazyByteString+{-# INLINE getRemainingByteString #-}++putLenEncBytes :: ByteString -> Put+putLenEncBytes c = do+ let l = B.length c+ putLenEncInt l+ putByteString c+{-# INLINE putLenEncBytes #-}++getLenEncBytes :: Get ByteString+getLenEncBytes = do+ b <- lookAhead getWord8+ if b == 0xfb+ then getWord8 >> return B.empty+ else getLenEncInt >>= getByteString+{-# INLINE getLenEncBytes #-}++-- | length encoded int+-- https://dev.mysql.com/doc/internals/en/integer.html#packet-Protocol::LengthEncodedInteger+getLenEncInt:: Get Int+getLenEncInt = getWord8 >>= word2Len+ where+ word2Len l+ | l < 0xfb = return (fromIntegral l)+ | l == 0xfc = fromIntegral <$> getWord16le+ | l == 0xfd = fromIntegral <$> getWord24le+ | l == 0xfe = fromIntegral <$> getWord64le+ | otherwise = fail $ "invalid length val " ++ show l+{-# INLINE getLenEncInt #-}++putLenEncInt:: Int -> Put+putLenEncInt x+ | x < 251 = putWord8 (fromIntegral x)+ | x < 65536 = putWord16le (fromIntegral x)+ | x < 16777216 = putWord24le (fromIntegral x)+ | otherwise = 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 #-}
+ Database/MySQL/Query.hs view
@@ -0,0 +1,49 @@+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 Control.Arrow (first)+import Database.MySQL.Protocol.MySQLValue+import Data.Binary.Put++-- | Query string type borrowed from @mysql-simple@.+--+-- This type is intended to make it difficult to+-- construct a SQL query by concatenating string fragments, as that is+-- an extremely common way to accidentally introduce SQL injection+-- vulnerabilities into an application.+--+-- This type is an instance of 'IsString', so the easiest way to+-- 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+-- that contain Unicode characters will be correctly transformed to+-- UTF-8.+--+newtype Query = Query { fromQuery :: L.ByteString } deriving (Eq, Ord, Typeable)++instance Show Query where+ show = show . fromQuery++instance Read Query where+ readsPrec i = fmap (first Query) . readsPrec i++instance IsString Query where+ fromString = Query . BB.toLazyByteString . BB.stringUtf8++renderParams :: Query -> [MySQLValue] -> Query+renderParams (Query qry) params =+ let fragments = LC.split '?' qry+ in Query . runPut $ merge fragments params+ where+ merge [x] [] = putLazyByteString x+ merge (x:xs) (y:ys) = putLazyByteString x >> putTextField y >> merge xs ys+ merge _ _ = throw WrongParamsCount++data WrongParamsCount = WrongParamsCount deriving (Show, Typeable)+instance Exception WrongParamsCount
+ LICENSE view
@@ -0,0 +1,30 @@+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.
+ README.md view
@@ -0,0 +1,124 @@+mysql-haskell+=============++[](https://travis-ci.org/winterland1989/mysql-haskell)++`mysql-haskell` is a MySQL driver written entirely in haskell by @winterland1989 at infrastructure department of Didi group, it's going to be used in projects aiming at replacing old java based MySQL middlewares.++This project is still in experimental stage and lack of produciton tests, use on your own risk, any form of contributions are welcomed!++Is it fast?+----------++In short, it's about 2 times slower than pure c/c++, but 5 times faster than old FFI bindings(mysql by Bryan O'Sullivan).++<img src="https://github.com/winterland1989/mysql-haskell/blob/master/benchmark/benchmark2016-08-14.png?raw=true">++Above figures showed the time to perform a "select * from employees" from a [sample table](https://github.com/datacharmer/test_db).++Motivation+----------++While MySQL may not be the most advanced sql database, it's widely used among China companies, including but not limited to Baidu, Alibaba, Tecent etc., but haskell's MySQL support is not ideal, we only have a very basic MySQL binding written by Bryan O'Sullivan, and some higher level wrapper built on it, which have some problems:+++ lack of prepared statment and binary protocol support.+++ limited concurrency due to FFI.+++ no replication protocol support.++`mysql-haskell` is intended to solve these problems, and provide foundation for higher level libraries such as groundhog and persistent, so that accessing MySQL is both fast and easy in haskell.++Build Test Benchmark+--------------------++Just use the old way:++```bash+git clone https://github.com/winterland1989/mysql-haskell.git+cd mysql-haskell+cabal install --only-dependencies+cabal build+```++Running tests require a local MySQL server, a user `testMySQLHaskell` and a database `testMySQLHaskell`, you can do it use following script:++```bash+mysql -u root -e "CREATE DATABASE IF NOT EXISTS testMySQLHaskell;"+mysql -u root -e "CREATE USER 'testMySQLHaskell'@'localhost' IDENTIFIED BY ''"+mysql -u root -e "GRANT ALL PRIVILEGES ON testMySQLHaskell.* TO 'testMySQLHaskell'@'localhost'"+mysql -u root -e "FLUSH PRIVILEGES"+```++You should enable binlog by adding `log_bin = filename` to `my.cnf` or add `--log-bin=filename` to the server, and grant replication access to `testMySQLHaskell` with:++```bash+mysql -u root -e "GRANT REPLICATION SLAVE, REPLICATION CLIENT ON *.* TO 'testMySQLHaskell'@'localhost';"+```++And you should set binlog to `row` by adding `binlog_format = ROW` to `my.cnf`.++New features in MySQL 5.7 are tested seperately, you can run them by setting environment varible `MYSQLVER=5.7`, travis is keeping+an eye on following combinations:+++ CABALVER=1.18 GHCVER=7.8.4 MYSQLVER=5.5++ CABALVER=1.22 GHCVER=7.10.2 MYSQLVER=5.5++ CABALVER=1.24 GHCVER=8.0.1 MYSQLVER=5.5++ CABALVER=1.24 GHCVER=8.0.1 MYSQLVER=5.6++ CABALVER=1.24 GHCVER=8.0.1 MYSQLVER=5.7++Please reference `.travis.yml` if you have problems with setting up test environment.++Enter benchmark directory and run `./bench.sh` to benchmark 1) c++ version 2) mysql-haskell 3) FFI version mysql, you may need to modify `bench.sh`(change the include path) to get c++ version compiled.++Guide+-----++Run `cabal haddock` and you will get pretty decent document.++Reference+---------++[MySQL official site](https://dev.mysql.com/doc/internals/en/) provided intensive document, but without following project, `mysql-haskell` may not be written at all:+++ [mysql-binlog-connector-java](https://github.com/shyiko/mysql-binlog-connector-java)+++ [canal](https://github.com/alibaba/canal)+++ [go mysql toolkit](https://github.com/siddontang/go-mysql)+++ [python binlog parser](https://github.com/noplay/python-mysql-replication)++License+-------++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ mysql-haskell.cabal view
@@ -0,0 +1,81 @@+name: mysql-haskell+version: 0.1.0.0+synopsis: pure haskell MySQL driver+description: pure haskell MySQL driver+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, README.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.Base+ , 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+++ other-modules: Database.MySQL.Connection+ , Database.MySQL.Query+ build-depends: base >= 4.7 && <5+ , transformers >= 0.3 && < 0.6+ , monad-loops == 0.4.*+ , network >= 2.3 && < 3.0+ , io-streams >= 1.2 && < 2.0+ , tcp-streams == 0.3.*+ , wire-streams >= 0.0.2 && < 0.1+ , binary >= 0.8.4+ , 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++ default-language: Haskell2010+ default-extensions: DeriveDataTypeable+ , DeriveGeneric+ , MultiWayIf+ , OverloadedStrings+ ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: BinaryRow, BinaryRowNew, BinLog, BinLogNew, TextRow, TextRowNew+ hs-source-dirs: test+ build-depends:+ mysql-haskell+ , base+ , bytestring+ , tasty+ , tasty-hunit+ , text+ , io-streams+ , time+ default-extensions: MultiWayIf+ , OverloadedStrings++ ghc-options: -threaded+ default-language: Haskell2010
+ test/BinLog.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}++module BinLog where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.Text.Encoding (encodeUtf8)+import Data.Time.Clock.POSIX+import Data.Time.Format+import Data.Time.LocalTime+import Database.MySQL.Base+import Database.MySQL.BinLog+import qualified System.IO.Streams as Stream+import Test.Tasty.HUnit++eventProducer :: IO ()+eventProducer = do+ c <- connect defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}+ execute_ c q1+ execute_ c q2+ return ()++tests :: MySQLConn -> Assertion+tests c = do+ Just blt <- getLastBinLogTracker c+ x@(fd, _, _) <- dumpBinLog c 1002 blt False+ rowEventStream <- decodeRowBinLogEvent x++ let Just t = parseTimeM True defaultTimeLocale "%F %T" "2016-08-08 17:25:59" :: Maybe LocalTime+ z <- getCurrentTimeZone+ let timestamp = round $ utcTimeToPOSIXSeconds (localTimeToUTC z t)++ Just (RowUpdateEvent _ tme ue) <- Stream.read rowEventStream+ assertEqual "decode update event cloumn" (updateColumnCnt ue) 30+ assertEqual "decode update event rows" (updateRowData ue)+ [+ (+ [ BinLogLong 0+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ , BinLogNull+ ], [ BinLogLong 0+ , BinLogBit 224+ , BinLogTiny (-128)+ , BinLogTiny (-1)+ , BinLogShort (-32768)+ , BinLogShort (-1)+ , BinLogInt24 (-8388608)+ , BinLogInt24 (-1)+ , BinLogLong (-2147483648)+ , BinLogLong (-1)+ , BinLogLongLong (-9223372036854775808)+ , BinLogLongLong (-1)+ , BinLogNewDecimal 1.2345678900123456789e9+ , BinLogFloat 3.14159+ , BinLogDouble 3.1415926535+ , BinLogDate 2016 8 8+ , BinLogDateTime 2016 8 8 17 25 59+ , BinLogTimeStamp timestamp+ , BinLogTime 0 199 59 59+ , BinLogYear 1999+ , BinLogBytes "12345678"+ , BinLogBytes (encodeUtf8 "韩冬真赞")+ , BinLogBytes "12345678"+ , BinLogBytes "12345678"+ , BinLogBytes "12345678"+ , BinLogBytes (encodeUtf8 "韩冬真赞")+ , BinLogBytes "12345678"+ , BinLogBytes (encodeUtf8 "韩冬真赞")+ , BinLogEnum 1+ , BinLogSet 3+ ]+ )+ ]++ Just (RowUpdateEvent _ tme ue) <- Stream.read rowEventStream+ assertEqual "decode update event rows" (updateRowData ue)+ [+ (+ [ BinLogLong 0+ , BinLogBit 224 -- 0b11100000+ , BinLogTiny (-128)+ , BinLogTiny (-1)+ , BinLogShort (-32768)+ , BinLogShort (-1)+ , BinLogInt24 (-8388608)+ , BinLogInt24 (-1)+ , BinLogLong (-2147483648)+ , BinLogLong (-1)+ , BinLogLongLong (-9223372036854775808)+ , BinLogLongLong (-1)+ , BinLogNewDecimal 1.2345678900123456789e9+ , BinLogFloat 3.14159+ , BinLogDouble 3.1415926535+ , BinLogDate 2016 8 8+ , BinLogDateTime 2016 8 8 17 25 59+ , BinLogTimeStamp timestamp+ , BinLogTime 0 199 59 59+ , BinLogYear 1999+ , BinLogBytes "12345678"+ , BinLogBytes (encodeUtf8 "韩冬真赞")+ , BinLogBytes "12345678"+ , BinLogBytes "12345678"+ , BinLogBytes "12345678"+ , BinLogBytes (encodeUtf8 "韩冬真赞")+ , BinLogBytes "12345678"+ , BinLogBytes (encodeUtf8 "韩冬真赞")+ , BinLogEnum 1+ , BinLogSet 3+ ], [ BinLogLong 0+ , BinLogBit 57514 -- 0b1110000010101010+ , BinLogTiny (-1)+ , BinLogTiny (-1)+ , BinLogShort (-32768)+ , BinLogShort (-1)+ , BinLogInt24 (-1)+ , BinLogInt24 (-1)+ , BinLogLong (-1)+ , BinLogLong (-1)+ , BinLogLongLong (-9223372036854775808)+ , BinLogLongLong (-1)+ , BinLogNewDecimal -1.2345678900123456789e9+ , BinLogFloat -3.14159+ , BinLogDouble -3.1415926535+ , BinLogDate 1800 8 8+ , BinLogDateTime 1800 8 8 17 25 59+ , BinLogTimeStamp timestamp+ , BinLogTime 1 199 59 59+ , BinLogYear 1901+ , BinLogBytes "12345678"+ , BinLogBytes (encodeUtf8 "韩冬真赞")+ , BinLogBytes "12345678"+ , BinLogBytes "12345678"+ , BinLogBytes "12345678"+ , BinLogBytes (encodeUtf8 "韩冬真赞")+ , BinLogBytes "12345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123"+ , BinLogBytes (encodeUtf8 "韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞")+ , BinLogEnum 1+ , BinLogSet 3+ ]+ )+ ]+q1 :: Query+q1 = "UPDATE test SET \+ \__bit = b'11100000' ,\+ \__tinyInt = -128 ,\+ \__tinyIntU = 255 ,\+ \__smallInt = -32768 ,\+ \__smallIntU = 65535 ,\+ \__mediumInt = -8388608 ,\+ \__mediumIntU = 16777215 ,\+ \__int = -2147483648 ,\+ \__intU = 4294967295 ,\+ \__bigInt = -9223372036854775808 ,\+ \__bigIntU = 18446744073709551615 ,\+ \__decimal = 1234567890.0123456789 ,\+ \__float = 3.14159 ,\+ \__double = 3.1415926535 ,\+ \__date = '2016-08-08' ,\+ \__datetime = '2016-08-08 17:25:59' ,\+ \__timestamp = '2016-08-08 17:25:59' ,\+ \__time = '-199:59:59' ,\+ \__year = 1999 ,\+ \__char = '12345678' ,\+ \__varchar = '韩冬真赞' ,\+ \__binary = '12345678' ,\+ \__varbinary = '12345678' ,\+ \__tinyblob = '12345678' ,\+ \__tinytext = '韩冬真赞' ,\+ \__blob = '12345678' ,\+ \__text = '韩冬真赞' ,\+ \__enum = 'foo' ,\+ \__set = 'foo,bar' WHERE __id=0"+++q2 :: Query+q2 = "UPDATE test SET \+ \__bit = b'1110000010101010' ,\+ \__tinyInt = -1 ,\+ \__tinyIntU = 255 ,\+ \__smallInt = -32768 ,\+ \__smallIntU = 65535 ,\+ \__mediumInt = -1 ,\+ \__mediumIntU = 16777215 ,\+ \__int = -1 ,\+ \__intU = 4294967295 ,\+ \__bigInt = -9223372036854775808 ,\+ \__bigIntU = 18446744073709551615 ,\+ \__decimal = -1234567890.0123456789 ,\+ \__float = -3.14159 ,\+ \__double = -3.1415926535 ,\+ \__date = '1800-08-08' ,\+ \__datetime = '1800-08-08 17:25:59' ,\+ \__timestamp = '2016-08-08 17:25:59' ,\+ \__time = '199:59:59' ,\+ \__year = 1901 ,\+ \__char = '12345678' ,\+ \__varchar = '韩冬真赞' ,\+ \__binary = '12345678' ,\+ \__varbinary = '12345678' ,\+ \__tinyblob = '12345678' ,\+ \__tinytext = '韩冬真赞' ,\+ \__blob = '12345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123' ,\+ \__text = '韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞' ,\+ \__enum = 'foo' ,\+ \__set = 'foo,bar' WHERE __id=0"
+ test/BinLogNew.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}++module BinLogNew where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.Time.Clock.POSIX+import Data.Time.Format+import Data.Time.LocalTime+import Database.MySQL.Base+import Database.MySQL.BinLog+import qualified System.IO.Streams as Stream+import Test.Tasty.HUnit++eventProducer :: IO ()+eventProducer = do+ c <- connect defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}+ execute_ c q1+ execute_ c q2+ execute_ c q3+ return ()++tests :: MySQLConn -> Assertion+tests c = do+ Just blt <- getLastBinLogTracker c+ x@(fd, _, _) <- dumpBinLog c 1002 blt False+ rowEventStream <- decodeRowBinLogEvent x++ let Just t = parseTimeM True defaultTimeLocale "%F %T%Q" "2016-08-08 17:25:59.1234" :: Maybe LocalTime+ z <- getCurrentTimeZone+ let timestamp = round $ utcTimeToPOSIXSeconds (localTimeToUTC z t)++ Just (RowUpdateEvent _ tme ue) <- Stream.read rowEventStream+ assertEqual "decode update event cloumn" (updateColumnCnt ue) 4+ assertEqual "decode update event rows" (updateRowData ue)+ [+ (+ [ BinLogLong 0+ , BinLogNull+ , BinLogNull+ , BinLogNull+ ], [ BinLogLong 0+ , BinLogDateTime2 2016 8 8 17 25 59 120000+ , BinLogTimeStamp2 timestamp 123400+ , BinLogTime2 0 199 59 59 123456+ ]+ )+ ]++ Just (RowUpdateEvent _ tme ue) <- Stream.read rowEventStream+ assertEqual "decode update event rows" (updateRowData ue)+ [+ (+ [ BinLogLong 0+ , BinLogDateTime2 2016 8 8 17 25 59 120000+ , BinLogTimeStamp2 timestamp 123400+ , BinLogTime2 0 199 59 59 123456+ ], [ BinLogLong 0+ , BinLogDateTime2 2016 8 8 17 25 59 100000+ , BinLogTimeStamp2 timestamp 123000+ , BinLogTime2 1 199 59 59 123450+ ]+ )+ ]++ Just (RowUpdateEvent _ tme ue) <- Stream.read rowEventStream+ assertEqual "decode update event rows" (updateRowData ue)+ [+ (+ [ BinLogLong 0+ , BinLogDateTime2 2016 8 8 17 25 59 100000+ , BinLogTimeStamp2 timestamp 123000+ , BinLogTime2 1 199 59 59 123450+ ], [ BinLogLong 0+ , BinLogNull+ , BinLogNull+ , BinLogTime2 0 0 59 59 123450+ ]+ )+ ]++q1 :: Query+q1 = "UPDATE test_new SET \+ \__datetime = '2016-08-08 17:25:59.12' ,\+ \__timestamp = '2016-08-08 17:25:59.1234' ,\+ \__time = '-199:59:59.123456' WHERE __id=0;"++q2 :: Query+q2 = "UPDATE test_new SET \+ \__datetime = '2016-08-08 17:25:59.1' ,\+ \__timestamp = '2016-08-08 17:25:59.123' ,\+ \__time = '199:59:59.12345' WHERE __id=0;"+++q3 :: Query+q3 = "UPDATE test_new SET \+ \__datetime = null ,\+ \__timestamp = null ,\+ \__time = '-00:59:59.12345' WHERE __id=0;"
+ test/BinaryRow.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}++module BinaryRow where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.Time.Calendar (fromGregorian)+import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))+import Database.MySQL.Base+import qualified System.IO.Streams as Stream+import Test.Tasty.HUnit++tests :: MySQLConn -> Assertion+tests c = do+ selStmt <- prepareStmt c "SELECT * FROM test"++ (f, is) <- queryStmt c selStmt []+ assertEqual "decode Field types" (columnType <$> f)+ [ mySQLTypeLong+ , mySQLTypeBit+ , mySQLTypeTiny+ , mySQLTypeTiny+ , mySQLTypeShort+ , mySQLTypeShort+ , mySQLTypeInt24+ , mySQLTypeInt24+ , mySQLTypeLong+ , mySQLTypeLong+ , mySQLTypeLongLong+ , mySQLTypeLongLong+ , mySQLTypeNewDecimal+ , mySQLTypeFloat+ , mySQLTypeDouble+ , mySQLTypeDate+ , mySQLTypeDateTime+ , mySQLTypeTimestamp+ , mySQLTypeTime+ , mySQLTypeYear+ , mySQLTypeString+ , mySQLTypeVarString+ , mySQLTypeString+ , mySQLTypeVarString+ , mySQLTypeBlob+ , mySQLTypeBlob+ , mySQLTypeBlob+ , mySQLTypeBlob+ , mySQLTypeString+ , mySQLTypeString+ ]++ Just v <- Stream.read is+ assertEqual "decode NULL values" v+ [ MySQLInt32 0+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ ]++ Stream.skipToEof is++ let bitV = 43744 -- 0b1010101011100000++ execute_ c "UPDATE test SET \+ \__bit = b'1010101011100000' ,\+ \__tinyInt = -128 ,\+ \__tinyIntU = 255 ,\+ \__smallInt = -32768 ,\+ \__smallIntU = 65535 ,\+ \__mediumInt = -8388608 ,\+ \__mediumIntU = 16777215 ,\+ \__int = -2147483648 ,\+ \__intU = 4294967295 ,\+ \__bigInt = -9223372036854775808 ,\+ \__bigIntU = 18446744073709551615 ,\+ \__decimal = 1234567890.0123456789 ,\+ \__float = 3.14159 ,\+ \__double = 3.1415926535 ,\+ \__date = '2016-08-08' ,\+ \__datetime = '2016-08-08 17:25:59' ,\+ \__timestamp = '2016-08-08 17:25:59' ,\+ \__time = '-199:59:59' ,\+ \__year = 1999 ,\+ \__char = '12345678' ,\+ \__varchar = '韩冬真赞' ,\+ \__binary = '12345678' ,\+ \__varbinary = '12345678' ,\+ \__tinyblob = '12345678' ,\+ \__tinytext = '韩冬真赞' ,\+ \__blob = '12345678' ,\+ \__text = '韩冬真赞' ,\+ \__enum = 'foo' ,\+ \__set = 'foo,bar' WHERE __id=0"++ (_, is) <- queryStmt c selStmt []+ Just v <- Stream.read is++ assertEqual "decode binary protocol" v+ [ 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"]++ Stream.skipToEof is+ updStmt <- prepareStmt c+ "UPDATE test SET \+ \__bit = ? ,\+ \__tinyInt = ? ,\+ \__tinyIntU = ? ,\+ \__smallInt = ? ,\+ \__smallIntU = ? ,\+ \__mediumInt = ? ,\+ \__mediumIntU = ? ,\+ \__int = ? ,\+ \__intU = ? ,\+ \__bigInt = ? ,\+ \__bigIntU = ? ,\+ \__decimal = ? ,\+ \__float = ? ,\+ \__double = ? ,\+ \__date = ? ,\+ \__datetime = ? ,\+ \__timestamp = ? ,\+ \__time = ? ,\+ \__year = ? ,\+ \__char = ? ,\+ \__varchar = ? ,\+ \__binary = ? ,\+ \__varbinary = ? ,\+ \__tinyblob = ? ,\+ \__tinytext = ? ,\+ \__blob = ? ,\+ \__text = ? ,\+ \__enum = ? ,\+ \__set = ? WHERE __id=0"++ executeStmt c updStmt+ [ 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"+ ]++++ (_, is) <- queryStmt c selStmt []+ Just v <- Stream.read is++ assertEqual "roundtrip binary protocol" v+ [ 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"+ ]++ Stream.skipToEof is++ execute_ c "UPDATE test SET \+ \__mediumInt = null ,\+ \__double = null ,\+ \__text = null WHERE __id=0"++ (_, is) <- queryStmt c selStmt []+ Just v <- Stream.read is++ assertEqual "decode binary protocol with null" v+ [ MySQLInt32 0+ , MySQLBit bitV+ , MySQLInt8 (-128)+ , MySQLInt8U 255+ , MySQLInt16 (-32768)+ , MySQLInt16U 65535+ , MySQLNull+ , MySQLInt32U 16777215+ , MySQLInt32 (-2147483648)+ , MySQLInt32U 4294967295+ , MySQLInt64 (-9223372036854775808)+ , MySQLInt64U 18446744073709551615+ , MySQLDecimal 1234567890.0123456789+ , MySQLFloat 3.14159+ , MySQLNull+ , 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"+ , MySQLNull+ , MySQLText "foo"+ , MySQLText "foo,bar"+ ]++ Stream.skipToEof is++ updStmt1 <- prepareStmt c "UPDATE test SET \+ \__decimal = ? ,\+ \__date = ? ,\+ \__timestamp = ? WHERE __id=0"+ executeStmt c updStmt1 [MySQLNull, MySQLNull, MySQLNull]++ (_, is) <- queryStmt c selStmt []+ Just v <- Stream.read is++ assertEqual "roundtrip binary protocol with null" v+ [ MySQLInt32 0+ , MySQLBit bitV+ , MySQLInt8 (-128)+ , MySQLInt8U 255+ , MySQLInt16 (-32768)+ , MySQLInt16U 65535+ , MySQLNull+ , MySQLInt32U 16777215+ , MySQLInt32 (-2147483648)+ , MySQLInt32U 4294967295+ , MySQLInt64 (-9223372036854775808)+ , MySQLInt64U 18446744073709551615+ , MySQLNull+ , MySQLFloat 3.14159+ , MySQLNull+ , MySQLNull+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+ , MySQLNull+ , MySQLTime 1 (TimeOfDay 199 59 59)+ , MySQLYear 1999+ , MySQLText "12345678"+ , MySQLText "韩冬真赞"+ , MySQLBytes "12345678"+ , MySQLBytes "12345678"+ , MySQLBytes "12345678"+ , MySQLText "韩冬真赞"+ , MySQLBytes "12345678"+ , MySQLNull+ , MySQLText "foo"+ , MySQLText "foo,bar"+ ]++ Stream.skipToEof is+ execute_ c "UPDATE test SET \+ \__time = '199:59:59' ,\+ \__year = 0 WHERE __id=0"++ selStmt2 <- prepareStmt c "SELECT __time, __year FROM test"+ (_, is) <- queryStmt c selStmt2 []+ Just v <- Stream.read is++ assertEqual "decode binary protocol 2" v+ [ MySQLTime 0 (TimeOfDay 199 59 59)+ , MySQLYear 0+ ]++ Stream.skipToEof is++ updStmt2 <- prepareStmt c "UPDATE test SET \+ \__time = ? ,\+ \__year = ? WHERE __id=0"++ (_, is) <- queryStmt c selStmt2 [ MySQLTime 0 (TimeOfDay 199 59 59), MySQLYear 0]+ Just v <- Stream.read is++ assertEqual "roundtrip binary protocol 2" v+ [ MySQLTime 0 (TimeOfDay 199 59 59)+ , MySQLYear 0+ ]++ Stream.skipToEof is
+ test/BinaryRowNew.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}++module BinaryRowNew where++import Control.Applicative+import Data.Time.Calendar (fromGregorian)+import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))+import Database.MySQL.Base+import qualified System.IO.Streams as Stream+import Test.Tasty.HUnit++tests :: MySQLConn -> Assertion+tests c = do+ selStmt <- prepareStmt c "SELECT * FROM test_new"++ (f, is) <- queryStmt c selStmt []+ assertEqual "decode Field types" (columnType <$> f)+ [ mySQLTypeLong+ , mySQLTypeDateTime+ , mySQLTypeTimestamp+ , mySQLTypeTime+ ]++ Just v <- Stream.read is+ assertEqual "decode NULL values" v+ [ MySQLInt32 0+ , MySQLNull+ , MySQLNull+ , MySQLNull+ ]++ Stream.skipToEof is++ execute_ c "UPDATE test_new SET \+ \__datetime = '2016-08-08 17:25:59.12' ,\+ \__timestamp = '2016-08-08 17:25:59.1234' ,\+ \__time = '-199:59:59.123456' WHERE __id=0"++ (_, is) <- queryStmt c selStmt []+ Just v <- Stream.read is++ assertEqual "decode binary protocol" v+ [ MySQLInt32 0+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+ , MySQLTime 1 (TimeOfDay 199 59 59.123456)+ ]++ Stream.skipToEof is++ execute_ c "UPDATE test_new SET \+ \__datetime = '2016-08-08 17:25:59.1' ,\+ \__timestamp = '2016-08-08 17:25:59.12' ,\+ \__time = '199:59:59.123' WHERE __id=0"++ (_, is) <- queryStmt c selStmt []+ Just v <- Stream.read is++ assertEqual "decode binary protocol 2" v+ [ MySQLInt32 0+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTime 0 (TimeOfDay 199 59 59.123)+ ]++ Stream.skipToEof is++ updStmt <- prepareStmt c+ "UPDATE test_new SET \+ \__datetime = ? ,\+ \__timestamp = ? ,\+ \__time = ? WHERE __id=0"++ executeStmt c updStmt+ [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+ , MySQLTime 1 (TimeOfDay 199 59 59.123456)+ ]+++ (_, is) <- queryStmt c selStmt []+ Just v <- Stream.read is++ assertEqual "roundtrip binary protocol" v+ [ MySQLInt32 0+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+ , MySQLTime 1 (TimeOfDay 199 59 59.123456)+ ]++ Stream.skipToEof is++ executeStmt c updStmt+ [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTime 0 (TimeOfDay 199 59 59.1234)+ ]+++ (_, is) <- queryStmt c selStmt []+ Just v <- Stream.read is++ assertEqual "roundtrip binary protocol 2" v+ [ MySQLInt32 0+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTime 0 (TimeOfDay 199 59 59.1234)+ ]++ Stream.skipToEof is
+ test/Main.hs view
@@ -0,0 +1,157 @@+module Main where++import qualified BinaryRow+import qualified BinaryRowNew+import qualified BinLog+import qualified BinLogNew+import Control.Concurrent (forkIO, threadDelay)+import Control.Exception (bracket)+import Control.Monad+import qualified Data.ByteString as B+import Database.MySQL.Base+import Database.MySQL.BinLog+import System.Environment+import Test.Tasty+import Test.Tasty.HUnit+import qualified TextRow+import qualified TextRowNew++main :: IO ()++main = defaultMain $ testCaseSteps "mysql-haskell test suit" $ \step -> do+++ step "preparing table..."+ (greet, c) <- connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}++ let ver = greetingVersion greet+ isNew = "5.6" `B.isPrefixOf` ver+ || "5.7" `B.isPrefixOf` ver -- from MySQL 5.6.4 and up+ -- TIME, DATETIME, and TIMESTAMP support fractional seconds+++ execute_ c "DROP TABLE IF EXISTS test"+ execute_ c "DROP TABLE IF EXISTS test_new"++ execute_ c "CREATE TABLE test(\+ \__id INT,\+ \__bit BIT(16),\+ \__tinyInt TINYINT,\+ \__tinyIntU TINYINT UNSIGNED,\+ \__smallInt SMALLINT,\+ \__smallIntU SMALLINT UNSIGNED,\+ \__mediumInt MEDIUMINT,\+ \__mediumIntU MEDIUMINT UNSIGNED,\+ \__int INT,\+ \__intU INT UNSIGNED,\+ \__bigInt BIGINT,\+ \__bigIntU BIGINT UNSIGNED,\+ \__decimal DECIMAL(20,10),\+ \__float FLOAT,\+ \__double DOUBLE,\+ \__date DATE,\+ \__datetime DATETIME,\+ \__timestamp TIMESTAMP NULL,\+ \__time TIME,\+ \__year YEAR(4),\+ \__char CHAR(8),\+ \__varchar VARCHAR(1024),\+ \__binary BINARY(8),\+ \__varbinary VARBINARY(1024),\+ \__tinyblob TINYBLOB,\+ \__tinytext TINYTEXT,\+ \__blob BLOB,\+ \__text TEXT,\+ \__enum ENUM('foo', 'bar', 'qux'),\+ \__set SET('foo', 'bar', 'qux')\+ \) CHARACTER SET utf8"++ resetTestTable c++ step "testing text protocol"+ TextRow.tests c++ resetTestTable c++ step "testing binary protocol"+ BinaryRow.tests c++ resetTestTable c+++ when isNew $ do+ execute_ c "CREATE TABLE test_new(\+ \__id INT,\+ \__datetime DATETIME(2),\+ \__timestamp TIMESTAMP(4) NULL,\+ \__time TIME(6)\+ \) CHARACTER SET utf8"++ resetTest57Table c++ step "testing MySQL5.7 extra text protocol"+ TextRowNew.tests c++ resetTest57Table c++ step "testing MySQL5.7 extra binary protocol"+ BinaryRowNew.tests c++ void $ resetTest57Table c++ step "testing binlog protocol"++ if isNew+ then do+ forkIO BinLogNew.eventProducer+ BinLogNew.tests c+ else do+ forkIO BinLog.eventProducer+ BinLog.tests c++ close c++ where+ resetTestTable c = do+ execute_ c "DELETE FROM test WHERE __id=0"+ execute_ c "INSERT INTO test VALUES(\+ \0,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL,\+ \NULL\+ \)"++ resetTest57Table c = do+ execute_ c "DELETE FROM test_new WHERE __id=0"+ execute_ c "INSERT INTO test_new VALUES(\+ \0,\+ \NULL,\+ \NULL,\+ \NULL\+ \)"
+ test/TextRow.hs view
@@ -0,0 +1,372 @@+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TextRow where++import Control.Applicative+import Data.Time.Calendar (fromGregorian)+import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))+import Database.MySQL.Base+import qualified System.IO.Streams as Stream+import Test.Tasty.HUnit++tests :: MySQLConn -> Assertion+tests c = do+ (f, is) <- query_ c "SELECT * FROM test"++ assertEqual "decode Field types" (columnType <$> f)+ [ mySQLTypeLong+ , mySQLTypeBit+ , mySQLTypeTiny+ , mySQLTypeTiny+ , mySQLTypeShort+ , mySQLTypeShort+ , mySQLTypeInt24+ , mySQLTypeInt24+ , mySQLTypeLong+ , mySQLTypeLong+ , mySQLTypeLongLong+ , mySQLTypeLongLong+ , mySQLTypeNewDecimal+ , mySQLTypeFloat+ , mySQLTypeDouble+ , mySQLTypeDate+ , mySQLTypeDateTime+ , mySQLTypeTimestamp+ , mySQLTypeTime+ , mySQLTypeYear+ , mySQLTypeString+ , mySQLTypeVarString+ , mySQLTypeString+ , mySQLTypeVarString+ , mySQLTypeBlob+ , mySQLTypeBlob+ , mySQLTypeBlob+ , mySQLTypeBlob+ , mySQLTypeString+ , mySQLTypeString+ ]++ Just v <- Stream.read is+ assertEqual "decode NULL values" v+ [ MySQLInt32 0+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ , MySQLNull+ ]++ Stream.skipToEof is++ let bitV = 57514 -- 0b1110000010101010++ execute_ c "UPDATE test SET \+ \__bit = b'1110000010101010' ,\+ \__tinyInt = -128 ,\+ \__tinyIntU = 255 ,\+ \__smallInt = -32768 ,\+ \__smallIntU = 65535 ,\+ \__mediumInt = -8388608 ,\+ \__mediumIntU = 16777215 ,\+ \__int = -2147483648 ,\+ \__intU = 4294967295 ,\+ \__bigInt = -9223372036854775808 ,\+ \__bigIntU = 18446744073709551615 ,\+ \__decimal = 1234567890.0123456789 ,\+ \__float = 3.14159 ,\+ \__double = 3.1415926535 ,\+ \__date = '2016-08-08' ,\+ \__datetime = '2016-08-08 17:25:59' ,\+ \__timestamp = '2016-08-08 17:25:59' ,\+ \__time = '-199:59:59' ,\+ \__year = 1999 ,\+ \__char = '12345678' ,\+ \__varchar = '韩冬真赞' ,\+ \__binary = '12345678' ,\+ \__varbinary = '12345678' ,\+ \__tinyblob = '12345678' ,\+ \__tinytext = '韩冬真赞' ,\+ \__blob = '12345678' ,\+ \__text = '韩冬真赞' ,\+ \__enum = 'foo' ,\+ \__set = 'foo,bar' WHERE __id=0"++ (_, is) <- query_ c "SELECT * FROM test"+ Just v <- Stream.read is++ assertEqual "decode text protocol" v+ [ 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"+ ]++ Stream.skipToEof is++ execute c "UPDATE test SET \+ \__bit = ? ,\+ \__tinyInt = ? ,\+ \__tinyIntU = ? ,\+ \__smallInt = ? ,\+ \__smallIntU = ? ,\+ \__mediumInt = ? ,\+ \__mediumIntU = ? ,\+ \__int = ? ,\+ \__intU = ? ,\+ \__bigInt = ? ,\+ \__bigIntU = ? ,\+ \__decimal = ? ,\+ \__float = ? ,\+ \__double = ? ,\+ \__date = ? ,\+ \__datetime = ? ,\+ \__timestamp = ? ,\+ \__time = ? ,\+ \__year = ? ,\+ \__char = ? ,\+ \__varchar = ? ,\+ \__binary = ? ,\+ \__varbinary = ? ,\+ \__tinyblob = ? ,\+ \__tinytext = ? ,\+ \__blob = ? ,\+ \__text = ? ,\+ \__enum = ? ,\+ \__set = ? WHERE __id=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"+ ]+++ (_, is) <- query_ c "SELECT * FROM test"+ Just v <- Stream.read is++ assertEqual "roundtrip text protocol" v+ [ 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"+ ]++ Stream.skipToEof is+++ execute_ c "UPDATE test SET \+ \__mediumInt = null ,\+ \__double = null ,\+ \__text = null WHERE __id=0"++ (_, is) <- query_ c "SELECT * FROM test"+ Just v <- Stream.read is++ assertEqual "decode text protocol with null" v+ [ MySQLInt32 0+ , MySQLBit bitV+ , MySQLInt8 (-128)+ , MySQLInt8U 255+ , MySQLInt16 (-32768)+ , MySQLInt16U 65535+ , MySQLNull+ , MySQLInt32U 16777215+ , MySQLInt32 (-2147483648)+ , MySQLInt32U 4294967295+ , MySQLInt64 (-9223372036854775808)+ , MySQLInt64U 18446744073709551615+ , MySQLDecimal 1234567890.0123456789+ , MySQLFloat 3.14159+ , MySQLNull+ , 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"+ , MySQLNull+ , MySQLText "foo"+ , MySQLText "foo,bar"+ ]++ Stream.skipToEof is++ execute c "UPDATE test SET \+ \__decimal = ? ,\+ \__date = ? ,\+ \__timestamp = ? WHERE __id=0"+ [MySQLNull, MySQLNull, MySQLNull]++ (_, is) <- query_ c "SELECT * FROM test"+ Just v <- Stream.read is++ assertEqual "roundtrip text protocol with null" v+ [ MySQLInt32 0+ , MySQLBit bitV+ , MySQLInt8 (-128)+ , MySQLInt8U 255+ , MySQLInt16 (-32768)+ , MySQLInt16U 65535+ , MySQLNull+ , MySQLInt32U 16777215+ , MySQLInt32 (-2147483648)+ , MySQLInt32U 4294967295+ , MySQLInt64 (-9223372036854775808)+ , MySQLInt64U 18446744073709551615+ , MySQLNull+ , MySQLFloat 3.14159+ , MySQLNull+ , MySQLNull+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+ , MySQLNull+ , MySQLTime 1 (TimeOfDay 199 59 59)+ , MySQLYear 1999+ , MySQLText "12345678"+ , MySQLText "韩冬真赞"+ , MySQLBytes "12345678"+ , MySQLBytes "12345678"+ , MySQLBytes "12345678"+ , MySQLText "韩冬真赞"+ , MySQLBytes "12345678"+ , MySQLNull+ , MySQLText "foo"+ , MySQLText "foo,bar"+ ]++ Stream.skipToEof is++ execute_ c "UPDATE test SET \+ \__time = '199:59:59' ,\+ \__year = 0 WHERE __id=0"++ (_, is) <- query_ c "SELECT __time, __year FROM test"+ Just v <- Stream.read is++ assertEqual "decode text protocol 2" v+ [ MySQLTime 0 (TimeOfDay 199 59 59)+ , MySQLYear 0+ ]++ Stream.skipToEof is++ execute c "UPDATE test SET \+ \__time = ? ,\+ \__year = ? WHERE __id=0"+ [ MySQLTime 0 (TimeOfDay 199 59 59), MySQLYear 0]++ (_, is) <- query_ c "SELECT __time, __year FROM test"+ Just v <- Stream.read is++ assertEqual "roundtrip text protocol 2" v+ [ MySQLTime 0 (TimeOfDay 199 59 59)+ , MySQLYear 0+ ]++ Stream.skipToEof is
+ test/TextRowNew.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TextRowNew where++import Control.Applicative+import Data.Time.Calendar (fromGregorian)+import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))+import Database.MySQL.Base+import qualified System.IO.Streams as Stream+import Test.Tasty.HUnit++tests :: MySQLConn -> Assertion+tests c = do+ (f, is) <- query_ c "SELECT * FROM test_new"++ assertEqual "decode Field types" (columnType <$> f)+ [ mySQLTypeLong+ , mySQLTypeDateTime+ , mySQLTypeTimestamp+ , mySQLTypeTime+ ]++ Just v <- Stream.read is+ assertEqual "decode NULL values" v+ [ MySQLInt32 0+ , MySQLNull+ , MySQLNull+ , MySQLNull+ ]++ Stream.skipToEof is++ execute_ c "UPDATE test_new SET \+ \__datetime = '2016-08-08 17:25:59.12' ,\+ \__timestamp = '2016-08-08 17:25:59.1234' ,\+ \__time = '-199:59:59.123456' WHERE __id=0"++ (_, is) <- query_ c "SELECT * FROM test_new"+ Just v <- Stream.read is++ assertEqual "decode text protocol" v+ [ MySQLInt32 0+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+ , MySQLTime 1 (TimeOfDay 199 59 59.123456)+ ]++ Stream.skipToEof is++ execute_ c "UPDATE test_new SET \+ \__datetime = '2016-08-08 17:25:59.1' ,\+ \__timestamp = '2016-08-08 17:25:59.12' ,\+ \__time = '199:59:59.1234' WHERE __id=0"++ (_, is) <- query_ c "SELECT * FROM test_new"+ Just v <- Stream.read is++ assertEqual "decode text protocol 2" v+ [ MySQLInt32 0+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTime 0 (TimeOfDay 199 59 59.1234)+ ]++ Stream.skipToEof is++ execute c "UPDATE test_new SET \+ \__datetime = ? ,\+ \__timestamp = ? ,\+ \__time = ? WHERE __id=0"+ [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+ , MySQLTime 1 (TimeOfDay 199 59 59.123456)+ ]+++ (_, is) <- query_ c "SELECT * FROM test_new"+ Just v <- Stream.read is++ assertEqual "roundtrip text protocol" v+ [ MySQLInt32 0+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+ , MySQLTime 1 (TimeOfDay 199 59 59.123456)+ ]++ Stream.skipToEof is++ execute c "UPDATE test_new SET \+ \__datetime = ? ,\+ \__timestamp = ? ,\+ \__time = ? WHERE __id=0"+ [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTime 0 (TimeOfDay 199 59 59.1234)+ ]++ (_, is) <- query_ c "SELECT * FROM test_new"+ Just v <- Stream.read is++ assertEqual "roundtrip text protocol 2" v+ [ MySQLInt32 0+ , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+ , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+ , MySQLTime 0 (TimeOfDay 199 59 59.1234)+ ]++ Stream.skipToEof is