diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog for Hedis +## 0.10.2 + +* PR #108. Add TLS support + ## 0.10.1 * PR #104. Add a Semigroup instance (fix GHC 8.4) diff --git a/hedis.cabal b/hedis.cabal --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.10.1 +version: 0.10.2 synopsis: Client library for the Redis datastore: supports full command set, pipelining. @@ -78,6 +78,7 @@ resource-pool >= 0.2, stm, time, + tls >= 1.3, vector >= 0.9, HTTP, errors, diff --git a/src/Database/Redis.hs b/src/Database/Redis.hs --- a/src/Database/Redis.hs +++ b/src/Database/Redis.hs @@ -8,6 +8,20 @@ -- conn <- 'checkedConnect' 'defaultConnectInfo' -- @ -- + -- Connect to a Redis server using TLS: + -- + -- @ + -- -- connects to foobar.redis.cache.windows.net:6380 + -- import Network.TLS + -- import Network.TLS.Extra.Cipher + -- import Data.X509.CertificateStore + -- import Data.Default.Class (def) + -- (Just certStore) <- readCertificateStore "azure-redis.crt" + -- let tlsParams = (defaultParamsClient "foobar.redis.cache.windows.net" "") { clientSupported = def { supportedCiphers = ciphersuite_strong }, clientShared = def { sharedCAStore = certStore } } + -- let redisConnInfo = defaultConnectInfo { connectHost = "foobar.redis.cache.windows.net", connectPort = PortNumber 6380, connectTLSParams = Just tlsParams, connectAuth = Just "Foobar!" } + -- conn <- checkedConnect redisConnInfo + -- @ + -- -- Send commands to the server: -- -- @ diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -23,6 +23,7 @@ import Data.Time import Data.Typeable import Network +import Network.TLS (ClientParams) import Database.Redis.Protocol import qualified Database.Redis.ProtocolPipelining as PP @@ -173,6 +174,8 @@ -- ^ Optional timeout until connection to Redis gets -- established. 'ConnectTimeoutException' gets thrown if no socket -- get connected in this interval of time. + , connectTLSParams :: Maybe ClientParams + -- ^ Optional TLS parameters. TLS will be enabled if this is provided. } deriving Show data ConnectError = ConnectAuthError Reply @@ -191,6 +194,7 @@ -- connectMaxConnections = 50 -- Up to 50 connections -- connectMaxIdleTime = 30 -- Keep open for 30 seconds -- connectTimeout = Nothing -- Don't add timeout logic +-- connectTLSParams = Nothing -- Do not use TLS -- @ -- defaultConnectInfo :: ConnectInfo @@ -202,6 +206,7 @@ , connectMaxConnections = 50 , connectMaxIdleTime = 30 , connectTimeout = Nothing + , connectTLSParams = Nothing } -- |Constructs a 'Connection' pool to a Redis server designated by the @@ -215,7 +220,12 @@ let timeoutOptUs = round . (1000000 *) <$> connectTimeout conn <- PP.connect connectHost connectPort timeoutOptUs - runRedisInternal conn $ do + conn' <- case connectTLSParams of + Nothing -> return conn + Just tlsParams -> PP.enableTLS tlsParams conn + PP.beginReceiving conn' + + runRedisInternal conn' $ do -- AUTH case connectAuth of Nothing -> return () @@ -230,7 +240,7 @@ case resp of Left r -> liftIO $ throwIO $ ConnectSelectError r _ -> return () - return conn + return conn' destroy = PP.disconnect diff --git a/src/Database/Redis/ProtocolPipelining.hs b/src/Database/Redis/ProtocolPipelining.hs --- a/src/Database/Redis/ProtocolPipelining.hs +++ b/src/Database/Redis/ProtocolPipelining.hs @@ -15,7 +15,7 @@ -- module Database.Redis.ProtocolPipelining ( Connection, - connect, disconnect, request, send, recv, flush, + connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, ConnectionLostException(..), HostName, PortID(..) ) where @@ -28,20 +28,23 @@ import Control.Monad import qualified Scanner import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L import Data.IORef import Data.Typeable import Network import qualified Network.BSD as BSD import qualified Network.Socket as NS +import qualified Network.TLS as TLS import System.IO import System.IO.Error import System.IO.Unsafe import Database.Redis.Protocol +data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context data Connection = Conn - { connHandle :: Handle -- ^ Connection socket-handle. + { connCtx :: ConnectionContext -- ^ Connection socket-handle. , connReplies :: IORef [Reply] -- ^ Reply thunks for unsent requests. , connPending :: IORef [Reply] -- ^ Reply thunks for requests "in the pipeline". Refers to the same list as @@ -70,16 +73,13 @@ connect :: HostName -> PortID -> Maybe Int -> IO Connection connect hostName portID timeoutOpt = - bracketOnError hConnect hClose $ \connHandle -> do - hSetBinaryMode connHandle True + bracketOnError hConnect hClose $ \h -> do + hSetBinaryMode h True connReplies <- newIORef [] connPending <- newIORef [] connPendingCnt <- newIORef 0 - let conn = Conn{..} - rs <- connGetReplies conn - writeIORef connReplies rs - writeIORef connPending rs - return conn + let connCtx = NormalHandle h + return Conn{..} where hConnect = do phaseMVar <- newMVar PhaseUnknown @@ -104,16 +104,42 @@ hConnect' _ _ = connectTo hostName portID mkSocket = NS.socket NS.AF_INET NS.Stream 0 +enableTLS :: TLS.ClientParams -> Connection -> IO Connection +enableTLS tlsParams conn@Conn{..} = do + case connCtx of + NormalHandle h -> do + ctx <- TLS.contextNew h tlsParams + TLS.handshake ctx + return $ conn { connCtx = TLSContext ctx } + TLSContext _ -> return conn + +beginReceiving :: Connection -> IO () +beginReceiving conn = do + rs <- connGetReplies conn + writeIORef (connReplies conn) rs + writeIORef (connPending conn) rs + disconnect :: Connection -> IO () disconnect Conn{..} = do - open <- hIsOpen connHandle - when open (hClose connHandle) + case connCtx of + NormalHandle h -> do + open <- hIsOpen h + when open $ hClose h + TLSContext ctx -> do + TLS.bye ctx + TLS.contextClose ctx -- |Write the request to the socket output buffer, without actually sending. --- The 'Handle' is 'hFlush'ed when reading replies from the 'connHandle'. +-- The 'Handle' is 'hFlush'ed when reading replies from the 'connCtx'. send :: Connection -> S.ByteString -> IO () send Conn{..} s = do - ioErrorToConnLost (S.hPut connHandle s) + case connCtx of + NormalHandle h -> + ioErrorToConnLost $ S.hPut h s + + TLSContext ctx -> + ioErrorToConnLost $ TLS.sendData ctx (L.fromStrict s) + -- Signal that we expect one more reply from Redis. n <- atomicModifyIORef' connPendingCnt $ \n -> let n' = n+1 in (n', n') -- Limit the "pipeline length". This is necessary in long pipelines, to avoid @@ -135,7 +161,10 @@ -- for the multithreaded pub/sub code, the sending thread needs to explicitly flush the subscription -- change requests. flush :: Connection -> IO () -flush Conn{..} = hFlush connHandle +flush Conn{..} = + case connCtx of + NormalHandle h -> hFlush h + TLSContext ctx -> TLS.contextFlush ctx -- |Send a request and receive the corresponding reply request :: Connection -> S.ByteString -> IO Reply @@ -146,7 +175,7 @@ -- The spine of the list can be evaluated without forcing the replies. -- -- Evaluating/forcing a 'Reply' from the list will 'unsafeInterleaveIO' the --- reading and parsing from the 'connHandle'. To ensure correct ordering, each +-- reading and parsing from the 'connCtx'. To ensure correct ordering, each -- Reply first evaluates (and thus reads from the network) the previous one. -- -- 'unsafeInterleaveIO' only evaluates it's result once, making this function @@ -154,7 +183,7 @@ -- to call 'hFlush' here. The list constructor '(:)' must be called from -- /within/ unsafeInterleaveIO, to keep the replies in correct order. connGetReplies :: Connection -> IO [Reply] -connGetReplies Conn{..} = go S.empty (SingleLine "previous of first") +connGetReplies conn@Conn{..} = go S.empty (SingleLine "previous of first") where go rest previous = do -- lazy pattern match to actually delay the receiving @@ -177,9 +206,10 @@ return (r:rs) readMore = ioErrorToConnLost $ do - hFlush connHandle -- send any pending requests - S.hGetSome connHandle 4096 - + flush conn + case connCtx of + NormalHandle h -> S.hGetSome h 4096 + TLSContext ctx -> TLS.recvData ctx ioErrorToConnLost :: IO a -> IO a ioErrorToConnLost a = a `catchIOError` const errConnClosed diff --git a/src/Database/Redis/URL.hs b/src/Database/Redis/URL.hs --- a/src/Database/Redis/URL.hs +++ b/src/Database/Redis/URL.hs @@ -22,7 +22,7 @@ -- Username is ignored, path is used to specify the database: -- -- >>> parseConnectInfo "redis://username:password@host:42/2" --- Right (ConnInfo {connectHost = "host", connectPort = PortNumber 42, connectAuth = Just "password", connectDatabase = 2, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing}) +-- Right (ConnInfo {connectHost = "host", connectPort = PortNumber 42, connectAuth = Just "password", connectDatabase = 2, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing}) -- -- >>> parseConnectInfo "redis://username:password@host:42/db" -- Left "Invalid port: db" @@ -36,7 +36,7 @@ -- @'defaultConnectInfo'@: -- -- >>> parseConnectInfo "redis://" --- Right (ConnInfo {connectHost = "localhost", connectPort = PortNumber 6379, connectAuth = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing}) +-- Right (ConnInfo {connectHost = "localhost", connectPort = PortNumber 6379, connectAuth = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing}) -- parseConnectInfo :: String -> Either String ConnectInfo parseConnectInfo url = do