network-wait 0.1.2.0 → 0.2.0.0

raw patch · 7 files changed

+232/−15 lines, 7 filesdep +hedisPVP ok

version bump matches the API change (PVP)

Dependencies added: hedis

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• README.md +23/−0
• network-wait.cabal +46/−1
• src/Network/Wait.hs +12/−10
• src/Network/Wait/PostgreSQL.hs +6/−4
• src/Network/Wait/Redis.hs +84/−0
• test-redis/Spec.hs +54/−0

@@ -1,5 +1,12 @@ # Changelog for network-wait +## 0.2.0++- Add `Network.Wait.Redis` module with functions to wait for Redis servers to become ready to accept connections. This module and its dependency on `hedis` are not enabled by default. The `network-wait:redis` flag must be enabled for this package's Redis support.+- Generalise the `recoveringWith` function to allow it to return the result of a computation.+- The functions for TCP/Sockets now return the `Socket` if they are successful.+- The functions for PostgreSQL now return the `Connection` if they are successful.+ ## 0.1.2  - Compatibility with GHC 8.2 and Stack LTS 11

@@ -1,5 +1,9 @@ # network-wait +![MIT](https://img.shields.io/github/license/mbg/network-wait)+![CI](https://github.com/mbg/network-wait/workflows/build/badge.svg?branch=main)+[![Hackage](https://img.shields.io/hackage/v/network-wait)](https://hackage.haskell.org/package/network-wait)+ A lightweight Haskell library for waiting on networked services to become available. This is useful if you are e.g. building a web application which relies on a database server to be available, but which may not be immediately available on application startup.  ## Example@@ -36,6 +40,25 @@ Internally, this uses `postgresql-simple` to connect to the specified server (`defaultConnectInfo` in the example above) and send a `SELECT 1;` query. If the query is answered correctly, we consider the server to be in a state ready to accept commands.  The `Network.Wait.PostgreSQL` module is gated behind the `network-wait:postgres` flag so that the PostgreSQL-specific dependencies are only required when PostgresSQL support is required by users of this library.++## Example: Redis++The `network-wait` package can be compiled with the `network-wait:redis` flag (e.g. `stack build --flag network-wait:redis`) which enables support for checking the readiness of Redis servers specifically. Unlike the functions in the `Network.Wait` module, which only check that connections can be established, the functions in `Network.Wait.Redis` also check that a Redis server is ready to accept commands. To wait for a Redis server to become available and accept commands:++```haskell+import Control.Retry (retryPolicyDefault)+import Database.Redis (defaultConnectInfo)+import Network.Wait.Redis (waitRedis)++main :: IO ()+main = do+    waitRedis retryPolicyDefault defaultConnectInfo+    putStrLn "Yay, the Redis server is ready to accept commands!"+```++Internally, this uses `hedis` to connect to the specified server (`defaultConnectInfo` in the example above) and send a ping. If the ping is answered, we consider the server to be in a state ready to accept commands.++The `Network.Wait.Redis` module is gated behind the `network-wait:redis` flag so that the Redis-specific dependencies are only required when Redis support is required by users of this library.  ## See also 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           network-wait-version:        0.1.2.0+version:        0.2.0.0 synopsis:       Lightweight library for waiting on networked services to become available. description:    Please see the README on GitHub at <https://github.com/mbg/network-wait#readme> category:       Network@@ -30,6 +30,11 @@   manual: True   default: False +flag redis+  description: Enable Redis support.+  manual: True+  default: False+ library   exposed-modules:       Network.Wait@@ -46,9 +51,15 @@   if flag(postgres)     build-depends:         postgresql-simple+  if flag(redis)+    build-depends:+        hedis   if flag(postgres)     exposed-modules:         Network.Wait.PostgreSQL+  if flag(redis)+    exposed-modules:+        Network.Wait.Redis   default-language: Haskell2010  test-suite network-wait-test@@ -71,6 +82,9 @@   if flag(postgres)     build-depends:         postgresql-simple+  if flag(redis)+    build-depends:+        hedis   default-language: Haskell2010  test-suite network-wait-test-postgres@@ -92,7 +106,38 @@   if flag(postgres)     build-depends:         postgresql-simple+  if flag(redis)+    build-depends:+        hedis   if flag(postgres)+    buildable: True+  else+    buildable: False+  default-language: Haskell2010++test-suite network-wait-test-redis+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_network_wait+  hs-source-dirs:+      test-redis+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , exceptions+    , network+    , network-wait+    , retry+    , tasty+    , tasty-hunit+  if flag(postgres)+    build-depends:+        postgresql-simple+  if flag(redis)+    build-depends:+        hedis+  if flag(redis)     buildable: True   else     buildable: False

@@ -48,7 +48,7 @@ -- > waitTcp retryPolicyDefault "localhost" "80" waitTcp     :: (MonadIO m, MonadMask m)-    => RetryPolicyM m -> HostName -> ServiceName -> m ()+    => RetryPolicyM m -> HostName -> ServiceName -> m Socket waitTcp = waitTcpWith []  -- | `waitTcpVerbose` @outputHandler retryPolicy addrInfo@ is a variant@@ -59,7 +59,8 @@ -- > waitTcpVerbose putStrLn retryPolicyDefault "localhost" "80" waitTcpVerbose     :: (MonadIO m, MonadMask m)-    => (String -> m ()) -> RetryPolicyM m -> HostName -> ServiceName -> m ()+    => (String -> m ()) -> RetryPolicyM m -> HostName -> ServiceName+    -> m Socket waitTcpVerbose out =     waitTcpVerboseFormat @SomeException $     \b ex st -> out $ defaultLogMsg b ex st@@ -78,7 +79,7 @@     -> RetryPolicyM m     -> HostName     -> ServiceName-    -> m ()+    -> m Socket waitTcpVerboseFormat out = waitTcpWith [h]     where h = logRetries (const $ pure True) out @@ -88,7 +89,7 @@ waitTcpWith     :: (MonadIO m, MonadMask m)     => [RetryStatus -> Handler m Bool]-    -> RetryPolicyM m -> HostName -> ServiceName -> m ()+    -> RetryPolicyM m -> HostName -> ServiceName -> m Socket waitTcpWith hs policy host port = do     let hints = defaultHints { addrSocketType = Stream }     addr <- head <$> liftIO (getAddrInfo (Just hints) (Just host) (Just port))@@ -98,7 +99,7 @@ -- does not install any additional exception handlers. waitSocket     :: (MonadIO m, MonadMask m)-    => RetryPolicyM m -> AddrInfo -> m ()+    => RetryPolicyM m -> AddrInfo -> m Socket waitSocket = waitSocketWith []  -- | `waitSocketVerbose` @outputHandler retryPolicy addrInfo@ is a variant@@ -107,7 +108,7 @@ -- before passing the resulting `String` to @out@. waitSocketVerbose     :: (MonadIO m, MonadMask m)-    => (String -> m ()) -> RetryPolicyM m -> AddrInfo -> m ()+    => (String -> m ()) -> RetryPolicyM m -> AddrInfo -> m Socket waitSocketVerbose out =     waitSocketVerboseFormat @SomeException $     \b ex st -> out $ defaultLogMsg b ex st@@ -121,7 +122,7 @@     => (Bool -> e -> RetryStatus -> m ())     -> RetryPolicyM m     -> AddrInfo-    -> m ()+    -> m Socket waitSocketVerboseFormat out = waitSocketWith [h]     where h = logRetries (const $ pure True) out @@ -137,7 +138,8 @@ -- logger. waitSocketWith     :: (MonadIO m, MonadMask m)-    => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> AddrInfo -> m ()+    => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> AddrInfo+    -> m Socket waitSocketWith hs policy addr =     recoveringWith hs policy $     -- all of the networking code runs in IO@@ -145,7 +147,7 @@     -- we want to make sure that we close the socket after every attempt;     -- `bracket` will re-throw any error afterwards     bracket initSocket close $-        \sock -> connect sock (addrAddress addr)+        \sock -> connect sock (addrAddress addr) >> pure sock     where         initSocket =             socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)@@ -161,7 +163,7 @@ -- the standard output or a logger. recoveringWith     :: (MonadIO m, MonadMask m)-    => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> m () -> m ()+    => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> m a -> m a recoveringWith hs policy action =     -- apply the retry policy to the following code, with the combinations of     -- the `skipAsyncExceptions`, given, and default handlers. The order of

@@ -36,7 +36,7 @@ -- `waitPostgresWith` which does not install any additional handlers. waitPostgreSql     :: (MonadIO m, MonadMask m)-    => RetryPolicyM m -> ConnectInfo -> m ()+    => RetryPolicyM m -> ConnectInfo -> m Connection waitPostgreSql = waitPostgreSqlWith []  -- | `waitPostgreSqlVerbose` @outputHandler retryPolicy connectInfo@ is a variant@@ -45,7 +45,7 @@ -- before passing the resulting `String` to @out@. waitPostgreSqlVerbose     :: (MonadIO m, MonadMask m)-    => (String -> m ()) -> RetryPolicyM m -> ConnectInfo -> m ()+    => (String -> m ()) -> RetryPolicyM m -> ConnectInfo -> m Connection waitPostgreSqlVerbose out =     waitPostgreSqlVerboseFormat @SomeException $     \b ex st -> out $ defaultLogMsg b ex st@@ -59,7 +59,7 @@     => (Bool -> e -> RetryStatus -> m ())     -> RetryPolicyM m     -> ConnectInfo-    -> m ()+    -> m Connection waitPostgreSqlVerboseFormat out = waitPostgreSqlWith [h]     where h = logRetries (const $ pure True) out @@ -75,7 +75,8 @@ -- standard output or a logger. waitPostgreSqlWith     :: (MonadIO m, MonadMask m)-    => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> ConnectInfo -> m ()+    => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> ConnectInfo+    -> m Connection waitPostgreSqlWith hs policy info =     recoveringWith hs policy $     liftIO $@@ -83,5 +84,6 @@         rs <- query_ @[Int] con "SELECT 1;"         unless (rs == [[1]]) $ throwM $             fatalError "Unexpected result for SELECT 1."+        pure con  -------------------------------------------------------------------------------

@@ -0,0 +1,84 @@+-------------------------------------------------------------------------------+-- network-wait+-- Copyright 2022 Michael B. Gale (github@michael-gale.co.uk)+-------------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | This module exports variants of the functions from "Network.Wait"+-- specialised for Redis servers. In addition to checking whether a+-- connection can be established, the functions in this module also check+-- whether the Redis server is ready to accept commands using+-- `checkedConnect`. Unlike `checkedConnect`, we don't give up if the+-- connection fails, but instead use the specified retry policy to try again.+-- All functions in this module return the established connection if+-- successful.+module Network.Wait.Redis (+    waitRedis,+    waitRedisVerbose,+    waitRedisVerboseFormat,+    waitRedisWith+) where++-------------------------------------------------------------------------------++import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Retry++import Database.Redis++import Network.Wait++-------------------------------------------------------------------------------+++-- | `waitRedis` @retryPolicy connectInfo@ is a variant of+-- `waitRedisWith` which does not install any additional handlers.+waitRedis+    :: (MonadIO m, MonadMask m)+    => RetryPolicyM m -> ConnectInfo -> m Connection+waitRedis = waitRedisWith []++-- | `waitRedisVerbose` @outputHandler retryPolicy connectInfo@ is a variant+-- of `waitRedisVerboseFormat` which catches all exceptions derived from+-- `SomeException` and formats retry attempt information using `defaultLogMsg`+-- before passing the resulting `String` to @out@.+waitRedisVerbose+    :: (MonadIO m, MonadMask m)+    => (String -> m ()) -> RetryPolicyM m -> ConnectInfo -> m Connection+waitRedisVerbose out =+    waitRedisVerboseFormat @SomeException $+    \b ex st -> out $ defaultLogMsg b ex st++-- | `waitRedisVerboseFormat` @outputHandler retryPolicy connectInfo@ is a+-- variant of `waitRedisWith` which installs an extra handler based on+-- `logRetries` which passes status information for each retry attempt+-- to @outputHandler@.+waitRedisVerboseFormat+    :: forall e m . (MonadIO m, MonadMask m, Exception e)+    => (Bool -> e -> RetryStatus -> m ())+    -> RetryPolicyM m+    -> ConnectInfo+    -> m Connection+waitRedisVerboseFormat out = waitRedisWith [h]+    where h = logRetries (const $ pure True) out++-- | `waitRedisWith` @extraHandlers retryPolicy connectInfo@ will attempt+-- to connect to the Redis server using @connectInfo@ and check that the+-- server is ready to accept commands. If this check fails, @retryPolicy@ is+-- used to determine whether (and how often) this function should attempt to+-- retry establishing the connection. By default, this function will retry+-- after all exceptions (except for those given by `skipAsyncExceptions`).+-- This behaviour may be customised with @extraHandlers@ which are installed+-- after `skipAsyncExceptions`, but before the default exception handler. The+--  @extraHandlers@ may also be used to report retry attempts to e.g. the+-- standard output or a logger.+waitRedisWith+    :: (MonadIO m, MonadMask m)+    => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> ConnectInfo+    -> m Connection+waitRedisWith hs policy = recoveringWith hs policy . liftIO . checkedConnect++-------------------------------------------------------------------------------

@@ -0,0 +1,54 @@+-------------------------------------------------------------------------------+-- network-wait+-- Copyright 2022 Michael B. Gale (github@michael-gale.co.uk)+-------------------------------------------------------------------------------++{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE TypeApplications #-}++import Control.Monad.Catch+import Control.Retry+-- Only needed for base < 4.11, redundant otherwise+import Data.Semigroup++import Database.Redis++import Test.Tasty+import Test.Tasty.HUnit++import Network.Wait.Redis++-------------------------------------------------------------------------------++-- | Essentially the same as `retryPolicyDefault`, but here for compatibility+-- with older versions of `retry`.+testRetryPolicy :: Monad m => RetryPolicyM m+testRetryPolicy = constantDelay 50000 <> limitRetries 5++tests :: TestTree+tests = testGroup "Network.Wait.Redis"+    [ testCase "Can't connect to server that doesn't exist" $ do+        res <- try @IO @SomeException $+            waitRedis testRetryPolicy defaultConnectInfo{+                connectHost = "doesnotexist"+            }++        case res of+            Left _ -> pure ()+            Right _ -> assertFailure "`waitRedis` did not fail"+    , testCase "Can connect to server that does exist" $ do+            let policy = limitRetries 5 <> exponentialBackoff (2*1000*1000)+            res <- try @IO @SomeException $+                waitRedisVerbose putStrLn policy defaultConnectInfo++            case res of+                Left ex -> assertFailure $+                    "`waitRedisVerbose` caused an exception: " <> show ex+                Right _ -> pure ()+    ]++-- | `main` is the entry point to this test suite.+main :: IO ()+main = defaultMain tests++-------------------------------------------------------------------------------