diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for mysql-haskell +## 0.3.0.0 -- 2016-8-19 + +* Fix tls connection, change TLS implementation to HsOpenSSL, add benchmarks. +* Fix a bug in 'putLenEncInt' which cause sending large field fail. +* Various optimizations. + ## 0.2.0.0 -- 2016-8-19 * Fix OK packet decoder. diff --git a/Database/MySQL/BinLogProtocol/BinLogValue.hs b/Database/MySQL/BinLogProtocol/BinLogValue.hs --- a/Database/MySQL/BinLogProtocol/BinLogValue.hs +++ b/Database/MySQL/BinLogProtocol/BinLogValue.hs @@ -321,3 +321,4 @@ 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' + diff --git a/Database/MySQL/Connection.hs b/Database/MySQL/Connection.hs --- a/Database/MySQL/Connection.hs +++ b/Database/MySQL/Connection.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - {-| Module : Database.MySQL.Connection Description : Connection managment @@ -19,7 +17,6 @@ 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 @@ -29,20 +26,16 @@ import qualified Data.ByteString.Unsafe as B import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import qualified Data.TLSSetting as TLS 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 qualified Network.TLS as TLS 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 -------------------------------------------------------------------------------- @@ -63,14 +56,12 @@ , 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 +defaultConnectInfo = ConnectInfo "127.0.0.1" 3306 "" "root" "" -------------------------------------------------------------------------------- @@ -89,47 +80,29 @@ -- | 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 +connectDetail ci@(ConnectInfo host port _ _ _) = + 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 +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 + where scramble :: ByteString -> ByteString -> ByteString scramble salt pass | B.null pass = B.empty @@ -140,17 +113,17 @@ 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 - +-- | A specialized 'decodeInputStream' here for speed +decodeInputStream :: InputStream ByteString -> IO (InputStream Packet) +decodeInputStream is = Stream.makeInputStream $ do + bs <- Stream.readExactly 4 is + let len = fromIntegral (bs `B.unsafeIndex` 0) + .|. fromIntegral (bs `B.unsafeIndex` 1) `shiftL` 8 + .|. fromIntegral (bs `B.unsafeIndex` 2) `shiftL` 16 + seqN = bs `B.unsafeIndex` 3 + body <- loopRead [] len is + return . Just $ Packet len seqN body + where loopRead acc 0 _ = return $! L.fromChunks (reverse acc) loopRead acc k is = do bs <- Stream.read is @@ -214,7 +187,7 @@ {-# INLINE readPacket #-} writeCommand :: Command -> OutputStream Packet -> IO () -writeCommand a os = let bs = Binary.runPut (Binary.put a) in +writeCommand a os = let bs = Binary.runPut (putCommand a) in go (fromIntegral (L.length bs)) 0 bs os where go len seqN bs os' = do @@ -238,50 +211,6 @@ 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_MULTI_STATEMENTS - .|. 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 diff --git a/Database/MySQL/OpenSSL.hs b/Database/MySQL/OpenSSL.hs new file mode 100644 --- /dev/null +++ b/Database/MySQL/OpenSSL.hs @@ -0,0 +1,60 @@ +{-| +Module : Database.MySQL.Connection +Description : Connection managment +Copyright : (c) Winterland, 2016 +License : BSD +Maintainer : drkoster@qq.com +Stability : experimental +Portability : PORTABLE + +This module provides secure MySQL connection using 'HsOpenSSL' package. + +-} + +module Database.MySQL.OpenSSL where + +import Control.Exception (bracketOnError, throwIO) +import Control.Monad +import Data.IORef (newIORef) +import Database.MySQL.Connection hiding (connect, connectDetail) +import Database.MySQL.Protocol.Auth +import Database.MySQL.Protocol.Packet +import qualified Network.Socket as N +import qualified OpenSSL as SSL +import qualified OpenSSL.Session as Session +import qualified System.IO.Streams as Stream +import qualified System.IO.Streams.Binary as Binary +import qualified System.IO.Streams.OpenSSL as SSL +import qualified System.IO.Streams.TCP as TCP + +-------------------------------------------------------------------------------- + +connect :: ConnectInfo -> Session.SSLContext -> IO MySQLConn +connect c cp = fmap snd (connectDetail c cp) + +connectDetail :: ConnectInfo -> Session.SSLContext -> IO (Greeting, MySQLConn) +connectDetail ci@(ConnectInfo host port _ _ _) ctx = + 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 + if supportTLS (greetingCaps greet) + then SSL.withOpenSSL $ do + Stream.write (Just (encodeToPacket 1 sslRequest)) os' + bracketOnError (Session.connection ctx sock) SSL.close $ \ ssl -> do + Session.connect ssl + (sslIs, sslOs) <- SSL.sslToStreams ssl + sslIs' <- decodeInputStream sslIs + sslOs' <- Binary.encodeOutputStream sslOs + let auth = mkAuth ci greet + Stream.write (Just (encodeToPacket 2 auth)) sslOs' + q <- readPacket sslIs' + if isOK q + then do + consumed <- newIORef True + let conn = MySQLConn sslIs' sslOs' (SSL.close ssl) consumed + return (greet, conn) + else Stream.write Nothing sslOs' >> decodeFromPacket q >>= throwIO . ERRException + else error "Database.MySQL.OpenSSL: server doesn't support TLS connection" diff --git a/Database/MySQL/Protocol/Auth.hs b/Database/MySQL/Protocol/Auth.hs --- a/Database/MySQL/Protocol/Auth.hs +++ b/Database/MySQL/Protocol/Auth.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-| @@ -22,48 +23,90 @@ import Data.Binary.Put import qualified Data.ByteString as B import Data.ByteString.Char8 as BC +import Data.Bits import Database.MySQL.Protocol.Packet -------------------------------------------------------------------------------- -- Authentications +#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 + data Greeting = Greeting { greetingProtocol :: !Word8 , greetingVersion :: !B.ByteString - , greetingTid :: !Word32 + , greetingConnId :: !Word32 , greetingSalt1 :: !B.ByteString - , greetingCaps :: !Word16 - , greetingLang :: !Word8 + , greetingCaps :: !Word32 + , greetingCharset :: !Word8 , greetingStatus :: !Word16 , greetingSalt2 :: !B.ByteString + , greetingAuthPlugin :: !B.ByteString } deriving (Show, Eq) putGreeting :: Greeting -> Put -putGreeting (Greeting p v t s1 c l st s2) = do - putWord8 p - putByteString v +putGreeting (Greeting pv sv cid salt1 cap charset st salt2 authPlugin) = do + putWord8 pv + putByteString sv putWord8 0x00 - putWord32le t - putByteString s1 - putWord16le c - putWord8 l + putWord32le cid + putByteString salt1 + let capL = fromIntegral cap .|. 0xFF + capH = fromIntegral (cap `shiftR` 16) .|. 0xFF + putWord16le capL + putWord8 charset putWord16le st - replicateM_ 13 (putWord8 0x00) - putByteString s2 + putWord16le capH + putWord8 (fromIntegral $ B.length salt2) + replicateM_ 10 (putWord8 0x00) + when (cap .&. CLIENT_SECURE_CONNECTION /= 0) + (putByteString salt2) + when (cap .&. CLIENT_PLUGIN_AUTH /= 0) + (putByteString authPlugin) getGreeting :: Get Greeting -getGreeting = Greeting - <$> getWord8 - <*> getByteStringNul - <*> getWord32le - <*> getByteStringNul - <*> getWord16le - <*> getWord8 - <*> getWord16le - <* skip 13 - <*> getByteStringNul - <* getByteStringNul +getGreeting = do + pv <- getWord8 + sv <- getByteStringNul + cid <- getWord32le + salt1 <- getByteString 8 + skip 1 -- 0x00 + capL <- getWord16le + charset <- getWord8 + status <- getWord16le + capH <- getWord16le + let cap = fromIntegral capH `shiftL` 16 .|. fromIntegral capL + authPluginLen <- getWord8 + skip 10 -- 10 * 0x00 + salt2 <- if (cap .&. CLIENT_SECURE_CONNECTION) == 0 + then pure B.empty + else let len = max 13 (authPluginLen - 8) in getByteString (fromIntegral len) + authPlugin <- if (cap .&. CLIENT_PLUGIN_AUTH) == 0 + then pure B.empty + else getByteStringNul + return (Greeting pv sv cid salt1 cap charset status salt2 authPlugin) + instance Binary Greeting where get = getGreeting put = putGreeting @@ -101,3 +144,50 @@ instance Binary Auth where get = getAuth put = putAuth + +data SSLRequest = SSLRequest + { sslReqCaps :: !Word32 + , sslReqMaxPacket :: !Word32 + , sslReqCharset :: !Word8 + } deriving (Show, Eq) + +getSSLRequest :: Get SSLRequest +getSSLRequest = SSLRequest <$> getWord32le <*> getWord32le <*> getWord8 <* skip 23 + +putSSLRequest :: SSLRequest -> Put +putSSLRequest (SSLRequest cap m c) = do + putWord32le cap + putWord32le m + putWord8 c + replicateM_ 23 (putWord8 0x00) + +instance Binary SSLRequest where + get = getSSLRequest + put = putSSLRequest + +-------------------------------------------------------------------------------- +-- default Capability Flags + +clientCap :: Word32 +clientCap = CLIENT_LONG_PASSWORD + .|. CLIENT_LONG_FLAG + .|. CLIENT_CONNECT_WITH_DB + .|. CLIENT_IGNORE_SPACE + .|. CLIENT_PROTOCOL_41 + .|. CLIENT_TRANSACTIONS + .|. CLIENT_MULTI_STATEMENTS + .|. 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 + +supportTLS :: Word32 -> Bool +supportTLS x = (x .&. CLIENT_SSL) /= 0 + +sslRequest :: SSLRequest +sslRequest = SSLRequest (clientCap .|. CLIENT_SSL) clientMaxPacketSize clientCharset diff --git a/Database/MySQL/Protocol/Command.hs b/Database/MySQL/Protocol/Command.hs --- a/Database/MySQL/Protocol/Command.hs +++ b/Database/MySQL/Protocol/Command.hs @@ -21,7 +21,7 @@ import Data.Binary.Get import Data.Binary.Put import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy as L import Database.MySQL.Protocol.MySQLValue import Database.MySQL.Protocol.Packet @@ -48,25 +48,6 @@ | 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 @@ -103,10 +84,6 @@ putCommand (COM_STMT_RESET stid) = putWord8 0x1A >> putWord32le stid putCommand _ = fail "unsupported command" -instance Binary Command where - get = getCommand - put = putCommand - -------------------------------------------------------------------------------- -- Prepared statment related @@ -120,10 +97,10 @@ getStmtPrepareOK :: Get StmtPrepareOK getStmtPrepareOK = do - _ <- getWord8 -- OK byte + skip 1 -- OK byte stmtid <- getWord32le cc <- fromIntegral <$> getWord16le pc <- fromIntegral <$> getWord16le - _ <- getWord8 -- reserved + skip 1 -- reserved wc <- fromIntegral <$> getWord16le return (StmtPrepareOK stmtid cc pc wc) diff --git a/Database/MySQL/Protocol/MySQLValue.hs b/Database/MySQL/Protocol/MySQLValue.hs --- a/Database/MySQL/Protocol/MySQLValue.hs +++ b/Database/MySQL/Protocol/MySQLValue.hs @@ -152,9 +152,7 @@ || 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 == '-' + if bs `B.unsafeIndex` 0 == 45 -- '-' then MySQLTime 1 <$> timeParser (B.unsafeDrop 1 bs) else MySQLTime 0 <$> timeParser bs @@ -169,9 +167,7 @@ || 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 + | t == mySQLTypeBit = MySQLBit <$> (getBits =<< getLenEncInt) | otherwise = fail $ "Database.MySQL.Protocol.MySQLValue: missing text decoder for " ++ show t where @@ -192,16 +188,16 @@ (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 #-} +feedLenEncBytes :: FieldType -> (t -> b) -> (ByteString -> Maybe t) -> Get b +feedLenEncBytes typ con parser = do + bs <- getLenEncBytes + case parser bs of + Just v -> return (con v) + Nothing -> fail $ "Database.MySQL.Protocol.MySQLValue: parsing " ++ show typ ++ " failed, \ + \input: " ++ BC.unpack bs +{-# INLINE feedLenEncBytes #-} + -------------------------------------------------------------------------------- -- | Text protocol encoder putTextField :: MySQLValue -> Put @@ -246,7 +242,7 @@ getTextRow fs = forM fs $ \ f -> do p <- lookAhead getWord8 if p == 0xFB - then getWord8 >> return MySQLNull + then skip 1 >> return MySQLNull else getTextField f {-# INLINE getTextRow #-} @@ -341,9 +337,7 @@ || 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 + | t == mySQLTypeBit = MySQLBit <$> (getBits =<< getLenEncInt) | otherwise = fail $ "Database.MySQL.Protocol.MySQLValue:\ \ missing binary decoder for " ++ show t where @@ -363,13 +357,6 @@ 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 -- @@ -436,6 +423,7 @@ putWord16le (fromIntegral yyyy) putWord8 (fromIntegral mm) putWord8 (fromIntegral dd) +{-# INLINE putBinaryDay #-} putBinaryTime' :: TimeOfDay -> Put putBinaryTime' (TimeOfDay hh mm ss) = do let s = floor ss @@ -444,6 +432,8 @@ putWord8 (fromIntegral mm) putWord8 s putWord32le ms +{-# INLINE putBinaryTime' #-} + putBinaryTime :: TimeOfDay -> Put putBinaryTime (TimeOfDay hh mm ss) = do let s = floor ss ms = floor $ (ss - realToFrac s) * 1000000 @@ -453,6 +443,7 @@ putWord8 (fromIntegral mm) putWord8 s putWord32le ms +{-# INLINE putBinaryTime #-} -------------------------------------------------------------------------------- -- | Binary row decoder @@ -461,7 +452,7 @@ -- getBinaryRow :: [ColumnDef] -> Int -> Get [MySQLValue] getBinaryRow fields flen = do - _ <- getWord8 -- 0x00 + skip 1 -- 0x00 let maplen = (flen + 7 + 2) `shiftR` 3 nullmap <- getByteString maplen go fields nullmap 0 @@ -482,6 +473,7 @@ {-# INLINE isNull #-} {-# INLINE getBinaryRow #-} +-------------------------------------------------------------------------------- -- | Use 'ByteString' to present a bitmap. -- -- When used for represent bits values, the underlining 'ByteString' follows: diff --git a/Database/MySQL/Protocol/Packet.hs b/Database/MySQL/Protocol/Packet.hs --- a/Database/MySQL/Protocol/Packet.hs +++ b/Database/MySQL/Protocol/Packet.hs @@ -205,17 +205,12 @@ putLenEncBytes :: ByteString -> Put putLenEncBytes c = do - let l = B.length c - putLenEncInt l - putByteString c + putLenEncInt (B.length c) + putByteString c {-# INLINE putLenEncBytes #-} getLenEncBytes :: Get ByteString -getLenEncBytes = do - b <- lookAhead getWord8 - if b == 0xfb - then getWord8 >> return B.empty - else getLenEncInt >>= getByteString +getLenEncBytes = getLenEncInt >>= getByteString {-# INLINE getLenEncBytes #-} -- | length encoded int @@ -224,19 +219,19 @@ getLenEncInt = getWord8 >>= word2Len where word2Len l - | l < 0xfb = return (fromIntegral l) - | l == 0xfc = fromIntegral <$> getWord16le - | l == 0xfd = fromIntegral <$> getWord24le - | l == 0xfe = fromIntegral <$> getWord64le + | l < 0xFB = pure (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) + | x < 251 = putWord8 (fromIntegral x) + | x < 65536 = putWord8 0xFC >> putWord16le (fromIntegral x) + | x < 16777216 = putWord8 0xFD >> putWord24le (fromIntegral x) + | otherwise = putWord8 0xFE >> putWord64le (fromIntegral x) {-# INLINE putLenEncInt #-} putWord24le :: Word32 -> Put diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,9 +11,9 @@ 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). +In short, `select`(decode) is about 2 times slower than pure c/c++, `insert` (encode) is about 1.5 times slower than pure c/c++, there're many factors involved(tls, prepared statment, batch using multiple statement): -![result figure](https://github.com/winterland1989/mysql-haskell/blob/master/benchmark/result.png?raw=true) + Above figures showed the time to: @@ -78,12 +78,14 @@ 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, and you may need to adjust rts options `-N` to get best results, with `-N10` on my company's 24-core machine, binary protocol performs almost identical to c version! +Enter benchmark directory and run `./bench.sh` to benchmark 1) c++ version 2) mysql-haskell 3) FFI version mysql, you may need to: -Guide ------ ++ modify `bench.sh`(change the include path) to get c++ version compiled. ++ modify `mysql-haskell-bench.cabal`(change the openssl's lib path) to get haskell version compiled. ++ setup MySQL's TLS support, modify `MySQLHaskellOpenSSL.hs` to change the CA file's path. ++ adjust rts options `-N` to get best results. -Run `cabal haddock` and you will get pretty decent document. +With `-N10` on my company's 24-core machine, binary protocol performs almost identical to c version! Reference --------- diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -1,5 +1,5 @@ name: mysql-haskell -version: 0.2.0.0 +version: 0.3.0.0 synopsis: pure haskell MySQL driver description: pure haskell MySQL driver license: BSD3 @@ -18,8 +18,13 @@ type: git location: git://github.com/winterland1989/mysql-haskell.git +flag openssl + description: Enable openssl support via @HsOpenSSL@ + default: True + library exposed-modules: Database.MySQL.Base + -- , Database.MySQL.TLS , Database.MySQL.Protocol.Auth , Database.MySQL.Protocol.Command , Database.MySQL.Protocol.ColumnDef @@ -30,16 +35,17 @@ , Database.MySQL.BinLogProtocol.BinLogEvent , Database.MySQL.BinLogProtocol.BinLogValue , Database.MySQL.BinLogProtocol.BinLogMeta + if flag(openssl) + exposed-modules: Database.MySQL.OpenSSL other-modules: Database.MySQL.Connection , Database.MySQL.Query - build-depends: base >= 4.7 && <5 - , transformers >= 0.3 && < 0.6 + build-depends: base >= 4.7 && < 5 , monad-loops == 0.4.* , network >= 2.3 && < 3.0 , io-streams >= 1.2 && < 2.0 - , tcp-streams == 0.3.* + , tcp-streams == 0.4.* , wire-streams >= 0.0.2 && < 0.1 , binary >= 0.8.4 , bytestring >= 0.10.2.0 @@ -51,7 +57,19 @@ , bytestring-lexing == 0.5.* , blaze-textual == 0.2.* , word24 == 1.* - , tls >= 1.3.5 && <1.4 + -- , tls >=1.3.5 && < 1.4 + + if flag(openssl) + build-depends: HsOpenSSL >=0.10.3 && <0.12 + if os(mingw32) || os(windows) + extra-libraries: eay32, ssl32 + else + if os(osx) + extra-libraries: crypto + extra-lib-dirs: /usr/local/lib + include-dirs: /usr/local/include + else + extra-libraries: crypto default-language: Haskell2010 default-extensions: DeriveDataTypeable diff --git a/test/BinaryRow.hs b/test/BinaryRow.hs --- a/test/BinaryRow.hs +++ b/test/BinaryRow.hs @@ -11,6 +11,8 @@ import Database.MySQL.Base import qualified System.IO.Streams as Stream import Test.Tasty.HUnit +import qualified Data.Text as T +import qualified Data.ByteString as B tests :: MySQLConn -> Assertion tests c = do @@ -85,7 +87,7 @@ ] Stream.skipToEof is - +-------------------------------------------------------------------------------- let bitV = 43744 -- 0b1010101011100000 execute_ c "UPDATE test SET \ @@ -155,6 +157,7 @@ , MySQLText "foo,bar"] Stream.skipToEof is +-------------------------------------------------------------------------------- updStmt <- prepareStmt c "UPDATE test SET \ \__bit = ? ,\ @@ -258,7 +261,7 @@ ] Stream.skipToEof is - +-------------------------------------------------------------------------------- execute_ c "UPDATE test SET \ \__mediumInt = null ,\ \__double = null ,\ @@ -301,7 +304,7 @@ ] Stream.skipToEof is - +-------------------------------------------------------------------------------- updStmt1 <- prepareStmt c "UPDATE test SET \ \__decimal = ? ,\ \__date = ? ,\ @@ -343,7 +346,7 @@ , MySQLText "foo" , MySQLText "foo,bar" ] - +-------------------------------------------------------------------------------- Stream.skipToEof is execute_ c "UPDATE test SET \ \__time = '199:59:59' ,\ @@ -359,17 +362,51 @@ ] 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 + executeStmt c updStmt2 [ MySQLTime 0 (TimeOfDay 00 00 00), MySQLYear 2055] + (_, is) <- queryStmt c selStmt2 [] + Just v <- Stream.read is assertEqual "roundtrip binary protocol 2" v - [ MySQLTime 0 (TimeOfDay 199 59 59) - , MySQLYear 0 + [ MySQLTime 0 (TimeOfDay 00 00 00) + , MySQLYear 2055 ] + + Stream.skipToEof is +-------------------------------------------------------------------------------- + execute_ c "UPDATE test SET \ + \__text = '' ,\ + \__blob = '' WHERE __id=0" + + selStmt3 <- prepareStmt c "SELECT __text, __blob FROM test" + (_, is) <- queryStmt c selStmt3 [] + Just v <- Stream.read is + + assertEqual "decode binary protocol 3" v + [ MySQLText "" + , MySQLBytes "" + ] + + Stream.skipToEof is +-------------------------------------------------------------------------------- + updStmt3 <- prepareStmt c "UPDATE test SET \ + \__text = ? ,\ + \__blob = ? WHERE __id=0" + + executeStmt c updStmt3 + [ MySQLText (T.replicate 100000 "xyz") + , MySQLBytes (B.replicate 1000000 64) + ] + + (_, is) <- queryStmt c selStmt3 [] + Just v <- Stream.read is + assertEqual "roundtrip binary protocol 3" v + [ MySQLText (T.replicate 100000 "xyz") + , MySQLBytes (B.replicate 1000000 64) + ] Stream.skipToEof is diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -62,8 +62,8 @@ \__varbinary VARBINARY(1024),\ \__tinyblob TINYBLOB,\ \__tinytext TINYTEXT,\ - \__blob BLOB,\ - \__text TEXT,\ + \__blob BLOB(1000000),\ + \__text TEXT(1000000),\ \__enum ENUM('foo', 'bar', 'qux'),\ \__set SET('foo', 'bar', 'qux')\ \) CHARACTER SET utf8" diff --git a/test/TextRow.hs b/test/TextRow.hs --- a/test/TextRow.hs +++ b/test/TextRow.hs @@ -355,6 +355,20 @@ Stream.skipToEof is + execute_ c "UPDATE test SET \ + \__text = '' ,\ + \__blob = '' WHERE __id=0" + + (_, is) <- query_ c "SELECT __text, __blob FROM test" + Just v <- Stream.read is + + assertEqual "decode text protocol 3" v + [ MySQLText "" + , MySQLBytes "" + ] + + Stream.skipToEof is + execute c "UPDATE test SET \ \__time = ? ,\ \__year = ? WHERE __id=0"