diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for mysql-haskell +## 0.8.2.0 -- 2016-11-09 + +Courtesy of naushadh, `mysql-haskell` will be on stackage again. + +* Update to use `tcp-streams-1.x`. +* Fix compatibility with new `tls/memory` version. + ## 0.8.1.0 -- 2016-11-09 * Add `Show` instance to `ConnectInfo`. diff --git a/Database/MySQL/BinLog.hs b/Database/MySQL/BinLog.hs --- a/Database/MySQL/BinLog.hs +++ b/Database/MySQL/BinLog.hs @@ -73,14 +73,14 @@ -- if master doesn't support, this parameter will be ignored. -> IO (FormatDescription, IORef ByteString, InputStream BinLogPacket) -- ^ 'FormatDescription', 'IORef' contains current binlog filename, 'BinLogPacket' stream. -dumpBinLog conn@(MySQLConn is os _ consumed) sid (BinLogTracker initfn initpos) wantAck = do +dumpBinLog conn@(MySQLConn is wp _ 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 + writeCommand (COM_BINLOG_DUMP initpos 0x00 sid initfn) wp writeIORef consumed False rp <- skipToPacketT (readBinLogPacket checksum needAck is) BINLOG_ROTATE_EVENT @@ -88,7 +88,7 @@ fref <- newIORef (rFileName re) p <- skipToPacketT (readBinLogPacket checksum needAck is) BINLOG_FORMAT_DESCRIPTION_EVENT - replyAck needAck p fref os + replyAck needAck p fref wp fmt <- getFromBinLogPacket getFormatDescription p es <- Stream.makeInputStream $ do @@ -98,7 +98,7 @@ Just q' -> do when (blEventType q' == BINLOG_ROTATE_EVENT) $ do e <- getFromBinLogPacket getRotateEvent q' writeIORef' fref (rFileName e) - replyAck needAck q' fref os + replyAck needAck q' fref wp return q return (fmt, fref, es) where @@ -109,9 +109,9 @@ if blEventType p' == typ then return p' else skipToPacketT iop typ Nothing -> throwIO NetworkException - replyAck needAck p fref os' = when (needAck && blSemiAck p) $ do + replyAck needAck p fref wp' = when (needAck && blSemiAck p) $ do fn <- readIORef fref - Stream.write (Just (makeSemiAckPacket (blLogPos p) fn)) os' + wp' (makeSemiAckPacket (blLogPos p) fn) makeSemiAckPacket pos fn = putToPacket 0 $ do putWord8 0xEF -- semi-ack diff --git a/Database/MySQL/Connection.hs b/Database/MySQL/Connection.hs --- a/Database/MySQL/Connection.hs +++ b/Database/MySQL/Connection.hs @@ -17,6 +17,7 @@ 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 @@ -37,6 +38,7 @@ 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 Data.Connection as TCP -------------------------------------------------------------------------------- @@ -47,7 +49,7 @@ -- data MySQLConn = MySQLConn { mysqlRead :: {-# UNPACK #-} !(InputStream Packet) - , mysqlWrite :: {-# UNPACK #-} !(OutputStream Packet) + , mysqlWrite :: (Packet -> IO ()) , mysqlCloseSocket :: IO () , isConsumed :: {-# UNPACK #-} !(IORef Bool) } @@ -105,22 +107,24 @@ -- | Establish a MySQL connection with 'Greeting' back, so you can find server's version .etc. -- connectDetail :: ConnectInfo -> IO (Greeting, MySQLConn) -connectDetail (ConnectInfo host port db user pass charset) = - 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 db user pass charset 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 +connectDetail (ConnectInfo host port db user pass charset) + = bracketOnError open TCP.close go + where + open = connectWithBufferSize host port bUFSIZE + go c = do + let is = TCP.source c + is' <- decodeInputStream is + p <- readPacket is' + greet <- decodeFromPacket p + let auth = mkAuth db user pass charset greet + write c $ encodeToPacket 1 auth + q <- readPacket is' + if isOK q + then do + consumed <- newIORef True + let conn = MySQLConn is' (write c) (TCP.close c) consumed + return (greet, conn) + else TCP.close c >> decodeFromPacket q >>= throwIO . ERRException mkAuth :: ByteString -> ByteString -> ByteString -> Word8 -> Greeting -> Auth mkAuth db user pass charset greet = @@ -166,9 +170,7 @@ -- | Close a MySQL connection. -- close :: MySQLConn -> IO () -close (MySQLConn _ os closeSocket _) = do - Stream.write Nothing os - closeSocket +close (MySQLConn _ _ closeSocket _) = closeSocket -- | Send a 'COM_PING'. -- @@ -211,20 +213,20 @@ ) {-# INLINE readPacket #-} -writeCommand :: Command -> OutputStream Packet -> IO () -writeCommand a os = let bs = Binary.runPut (putCommand a) in - go (fromIntegral (L.length bs)) 0 bs os +writeCommand :: Command -> (Packet -> IO ()) -> IO () +writeCommand a writePacket = let bs = Binary.runPut (putCommand a) in + go (fromIntegral (L.length bs)) 0 bs writePacket where - go len seqN bs os' = do + go len seqN bs writePacket' = do if len < 16777215 - then Stream.write (Just (Packet len seqN bs)) os' + then writePacket (Packet len seqN bs) else do let (bs', rest) = L.splitAt 16777215 bs seqN' = seqN + 1 len' = len - 16777215 - Stream.write (Just (Packet 16777215 seqN bs')) os' - seqN' `seq` len' `seq` go len' seqN' rest os' + writePacket (Packet 16777215 seqN bs') + seqN' `seq` len' `seq` go len' seqN' rest writePacket' {-# INLINE writeCommand #-} guardUnconsumed :: MySQLConn -> IO () @@ -251,3 +253,14 @@ data UnexpectedPacket = UnexpectedPacket Packet deriving (Typeable, Show) instance Exception UnexpectedPacket + +-------------------------------------------------------------------------------- +-- TCP shims + +type TCPConnection = TCP.Connection (N.Socket, N.SockAddr) + +connectWithBufferSize :: N.HostName -> N.PortNumber -> Int -> IO TCPConnection +connectWithBufferSize h p bs = TCP.connectSocket h p >>= TCP.socketToConnection bs + +write :: Binary.Binary a => TCP.Connection x -> a -> IO () +write c a = TCP.send c $ Binary.runPut . Binary.put $ a diff --git a/Database/MySQL/TLS.hs b/Database/MySQL/TLS.hs --- a/Database/MySQL/TLS.hs +++ b/Database/MySQL/TLS.hs @@ -29,6 +29,7 @@ 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 Data.Connection as TCP import qualified System.IO.Streams.TLS as TLS -------------------------------------------------------------------------------- @@ -40,10 +41,10 @@ connectDetail :: ConnectInfo -> (TLS.ClientParams, String) -> IO (Greeting, MySQLConn) connectDetail (ConnectInfo host port db user pass charset) (cparams, subName) = - bracketOnError (TCP.connectWithBufferSize host port bUFSIZE) - (\(_, _, sock) -> N.close sock) $ \ (is, os, sock) -> do + bracketOnError (connectWithBufferSize host port bUFSIZE) + (TCP.close) $ \ (c) -> do + let is = TCP.source c is' <- decodeInputStream is - os' <- Binary.encodeOutputStream os p <- readPacket is' greet <- decodeFromPacket p if supportTLS (greetingCaps greet) @@ -52,19 +53,18 @@ TLS.clientUseServerNameIndication = False , TLS.clientServerIdentification = (subName, "") } - Stream.write (Just (encodeToPacket 1 $ sslRequest charset)) os' - bracketOnError (TLS.contextNew sock cparams') TLS.close $ \ ctx -> do - TLS.handshake ctx - (tlsIs, tlsOs) <- TLS.tlsToStreams ctx + let connect' = TLS.connect cparams' Nothing host port + write c (encodeToPacket 1 $ sslRequest charset) + bracketOnError connect' TCP.close $ \ tc -> do + let tlsIs = TCP.source tc tlsIs' <- decodeInputStream tlsIs - tlsOs' <- Binary.encodeOutputStream tlsOs let auth = mkAuth db user pass charset greet - Stream.write (Just (encodeToPacket 2 auth)) tlsOs' + write tc (encodeToPacket 2 auth) q <- readPacket tlsIs' if isOK q then do consumed <- newIORef True - let conn = MySQLConn tlsIs' tlsOs' (TLS.close ctx) consumed + let conn = MySQLConn tlsIs' (write c) (TCP.close c) consumed return (greet, conn) - else Stream.write Nothing tlsOs' >> decodeFromPacket q >>= throwIO . ERRException + else TCP.close c >> decodeFromPacket q >>= throwIO . ERRException else error "Database.MySQL.TLS: server doesn't support TLS connection" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -66,7 +66,7 @@ ... s <- prepareStmt conn "SELECT * FROM some_table where person_age > ?" ... - (defs, is) <- queryStmt s [MySQLInt32U 18] + (defs, is) <- queryStmt conn s [MySQLInt32U 18] ... ``` diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -1,12 +1,12 @@ name: mysql-haskell -version: 0.8.1.0 +version: 0.8.2.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 +copyright: (c) 2016 Winterland category: Database build-type: Simple extra-source-files: ChangeLog.md, README.md @@ -20,7 +20,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 @@ -37,7 +37,7 @@ , monad-loops == 0.4.* , network >= 2.3 && < 3.0 , io-streams >= 1.2 && < 2.0 - , tcp-streams >= 0.6 && < 0.7 + , tcp-streams >= 1.0 && < 1.1 , wire-streams >= 0.1 , binary >= 0.8.3 , binary-ieee754 @@ -45,13 +45,13 @@ , bytestring >= 0.10.2.0 , text >= 1.1 && < 1.3 , cryptonite == 0.* - , memory <= 0.14.2 + , memory >= 0.14.4 && < 0.15 , time >= 1.5.0 , scientific == 0.3.* , bytestring-lexing == 0.5.* , blaze-textual == 0.2.* , word24 >= 1.0 && <= 3.0 - , tls >= 1.3.5 && < 1.4 + , tls >= 1.3.5 && < 1.5 , vector >= 0.8 default-language: Haskell2010 @@ -83,6 +83,5 @@ , vector default-extensions: MultiWayIf , OverloadedStrings - ghc-options: -threaded default-language: Haskell2010