diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for mysql-haskell-openssl + +## 0.7.0.0 -- 2016-11-09 + +* Split from mysql-haskell. 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,74 @@ +{-| +Module : Database.MySQL.Connection +Description : Alternative TLS support for mysql-haskell via @HsOpenSSL@ package. +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 + ( connect + , connectDetail + , module Data.OpenSSLSetting + ) 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.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 + +-------------------------------------------------------------------------------- + +-- | 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, String) -> IO (Greeting, MySQLConn) +connectDetail (ConnectInfo host port db user pass) (ctx, 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 SSL.withOpenSSL $ do + 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 + let auth = mkAuth db user pass 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mysql-haskell-openssl.cabal b/mysql-haskell-openssl.cabal new file mode 100644 --- /dev/null +++ b/mysql-haskell-openssl.cabal @@ -0,0 +1,37 @@ +name: mysql-haskell-openssl +version: 0.7.0.0 +synopsis: TLS support for mysql-haskell package using openssl +description: TLS support for mysql-haskell package using openssl +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 +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.OpenSSL + build-depends: base >= 4.7 && < 5 + , network >= 2.3 && < 3.0 + , io-streams >= 1.2 && < 2.0 + , tcp-streams >= 0.6 && < 0.7 + , tcp-streams-openssl >= 0.6 && < 0.7 + , wire-streams >= 0.1 + , mysql-haskell >= 0.7 + , HsOpenSSL >=0.10.3 && <0.12 + + default-language: Haskell2010 + default-extensions: DeriveDataTypeable + , DeriveGeneric + , MultiWayIf + , OverloadedStrings + ghc-options: -Wall