hedis 0.10.1 → 0.10.2

raw patch · 6 files changed

+83/−24 lines, 6 filesdep +tlsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: tls

API changes (from Hackage documentation)

Files

• CHANGELOG +4/−0
• hedis.cabal +2/−1
• src/Database/Redis.hs +14/−0
• src/Database/Redis/Core.hs +12/−2
• src/Database/Redis/ProtocolPipelining.hs +49/−19
• src/Database/Redis/URL.hs +2/−2

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

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

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

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

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

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