mysql-haskell 0.3.0.0 → 0.4.0.0

raw patch · 5 files changed

+97/−9 lines, 5 filesdep +tlsPVP ok

version bump matches the API change (PVP)

Dependencies added: tls

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−1
• Database/MySQL/OpenSSL.hs +18/−4
• Database/MySQL/TLS.hs +70/−0
• README.md +1/−1
• mysql-haskell.cabal +3/−3

@@ -1,6 +1,10 @@ # Revision history for mysql-haskell -## 0.3.0.0  -- 2016-8-19+## 0.4.0.0 -- 2016-8-22++* Enable TLS support via `tls` package, add benchmarks.++## 0.3.0.0  -- 2016-8-22  * Fix tls connection, change TLS implementation to HsOpenSSL, add benchmarks. * Fix a bug in 'putLenEncInt' which cause sending large field fail.

@@ -11,7 +11,11 @@  -} -module Database.MySQL.OpenSSL where+module Database.MySQL.OpenSSL+    ( connect+    , connectDetail+    , module Data.OpenSSLSetting+    ) where  import           Control.Exception              (bracketOnError, throwIO) import           Control.Monad@@ -21,19 +25,23 @@ import           Database.MySQL.Protocol.Packet import qualified Network.Socket                 as N import qualified OpenSSL                        as SSL+import qualified OpenSSL.X509                   as X509 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+import           Data.OpenSSLSetting  -------------------------------------------------------------------------------- -connect :: ConnectInfo -> Session.SSLContext -> IO MySQLConn+-- | Provide a 'Session.SSLContext' and a subject name to establish a TLS connection.+--+connect :: ConnectInfo -> (Session.SSLContext, String) -> IO MySQLConn connect c cp = fmap snd (connectDetail c cp) -connectDetail :: ConnectInfo -> Session.SSLContext -> IO (Greeting, MySQLConn)-connectDetail ci@(ConnectInfo host port _ _ _) ctx =+connectDetail :: ConnectInfo -> (Session.SSLContext, String) -> IO (Greeting, MySQLConn)+connectDetail ci@(ConnectInfo host port _ _ _) (ctx, subname) =     bracketOnError (TCP.connectWithBufferSize host port bUFSIZE)        (\(_, _, sock) -> N.close sock) $ \ (is, os, sock) -> do             is' <- decodeInputStream is@@ -45,6 +53,12 @@                 Stream.write (Just (encodeToPacket 1 sslRequest)) os'                 bracketOnError (Session.connection ctx sock) SSL.close $ \ ssl -> do                     Session.connect ssl+                    trusted <- Session.getVerifyResult ssl+                    cert <- Session.getPeerCertificate ssl+                    subnames <- maybe (return []) (`X509.getSubjectName` False) cert+                    let cnname = lookup "CN" subnames+                        verified = maybe False (== subname) cnname+                    unless (trusted && verified) (throwIO $ Session.ProtocolError "fail to verify certificate")                     (sslIs, sslOs) <- SSL.sslToStreams ssl                     sslIs' <- decodeInputStream sslIs                     sslOs' <- Binary.encodeOutputStream sslOs

@@ -0,0 +1,70 @@+{-|+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 'tls' package, please make sure your certificate is v3 extension enabled.++-}++module Database.MySQL.TLS (+      connect+    , connectDetail+    , module Data.TLSSetting+    ) where++import           Control.Exception              (bracketOnError, throwIO)+import           Control.Monad+import           Data.IORef                     (newIORef)+import           Data.TLSSetting+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 Network.TLS                    as TLS+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++--------------------------------------------------------------------------------++-- | Provide a 'TLS.ClientParams' and a subject name to establish a TLS connection.+--+connect :: ConnectInfo -> (TLS.ClientParams, String) -> IO MySQLConn+connect c cp = fmap snd (connectDetail c cp)++connectDetail :: ConnectInfo -> (TLS.ClientParams, String) -> IO (Greeting, MySQLConn)+connectDetail ci@(ConnectInfo host port _ _ _) (cparams, subName) =+    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 do+                let cparams' = cparams {+                            TLS.clientUseServerNameIndication = False+                        ,   TLS.clientServerIdentification = (subName, "")+                        }+                Stream.write (Just (encodeToPacket 1 sslRequest)) os'+                bracketOnError (TLS.contextNew sock cparams') TLS.close $ \ ctx -> do+                    TLS.handshake ctx+                    (tlsIs, tlsOs) <- TLS.tlsToStreams ctx+                    tlsIs' <- decodeInputStream tlsIs+                    tlsOs' <- Binary.encodeOutputStream tlsOs+                    let auth = mkAuth ci greet+                    Stream.write (Just (encodeToPacket 2 auth)) tlsOs'+                    q <- readPacket tlsIs'+                    if isOK q+                    then do+                        consumed <- newIORef True+                        let conn = MySQLConn tlsIs' tlsOs' (TLS.close ctx) consumed+                        return (greet, conn)+                    else Stream.write Nothing tlsOs' >> decodeFromPacket q >>= throwIO . ERRException+            else error "Database.MySQL.TLS: server doesn't support TLS connection"

@@ -82,7 +82,7 @@  + 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.++ setup MySQL's TLS support, modify `MySQLHaskellOpenSSL.hs/MySQLHaskellTLS.hs` to change the CA file's path, and certificate's subject name. + 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!

@@ -1,5 +1,5 @@ name:                mysql-haskell-version:             0.3.0.0+version:             0.4.0.0 synopsis:            pure haskell MySQL driver description:         pure haskell MySQL driver license:             BSD3@@ -24,7 +24,7 @@  library     exposed-modules:    Database.MySQL.Base-                    -- ,   Database.MySQL.TLS       +                    ,   Database.MySQL.TLS                            ,   Database.MySQL.Protocol.Auth                     ,   Database.MySQL.Protocol.Command                     ,   Database.MySQL.Protocol.ColumnDef@@ -57,7 +57,7 @@                     ,   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