mysql-haskell 0.2.0.0 → 0.3.0.0

raw patch · 13 files changed

+342/−221 lines, 13 filesdep +HsOpenSSLdep −tlsdep −transformersdep ~tcp-streamsPVP ok

version bump matches the API change (PVP)

Dependencies added: HsOpenSSL

Dependencies removed: tls, transformers

Dependency ranges changed: tcp-streams

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• Database/MySQL/BinLogProtocol/BinLogValue.hs +1/−0
• Database/MySQL/Connection.hs +36/−107
• Database/MySQL/OpenSSL.hs +60/−0
• Database/MySQL/Protocol/Auth.hs +113/−23
• Database/MySQL/Protocol/Command.hs +3/−26
• Database/MySQL/Protocol/MySQLValue.hs +19/−27
• Database/MySQL/Protocol/Packet.hs +11/−16
• README.md +8/−6
• mysql-haskell.cabal +23/−5
• test/BinaryRow.hs +46/−9
• test/Main.hs +2/−2
• test/TextRow.hs +14/−0

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

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

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

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

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

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

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

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

@@ -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)+<img src="https://github.com/winterland1989/mysql-haskell/blob/master/benchmark/result.png?raw=true" width="100%">  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 ---------

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

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

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

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