packages feed

network-wait 0.1.0.0 → 0.1.1.0

raw patch · 6 files changed

+227/−7 lines, 6 filesdep +postgresql-simple

Dependencies added: postgresql-simple

Files

ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for network-wait +## 0.1.1++- Add `Network.Wait.PostgreSQL` module with functions to wait for PostgreSQL servers to become ready to accept connections. This module and its dependency on `postgresql-simple` are not enabled by default. The `network-wait:postgres` flag must be enabled for this package's PostgreSQL support.+ ## 0.1.0  - First release
README.md view
@@ -18,6 +18,25 @@  The haddock documentation for this library contains more examples. +## Example: PostgreSQL++The `network-wait` package can be compiled with the `network-wait:postgres` flag (e.g. `stack build --flag network-wait:postgres`) which enables support for checking the readiness of PostgreSQL servers specifically. Unlike the functions in the `Network.Wait` module, which only check that connections can be established, the functions in `Network.Wait.PostgreSQL` also check that a PostgreSQL server is ready to accept commands. To wait for a PostgreSQL server to become available and accept commands:++```haskell+import Control.Retry (retryPolicyDefault)+import Database.PostgreSQL.Simple (defaultConnectInfo)+import Network.Wait.PostgreSQL (waitPostgreSQL)++main :: IO ()+main = do+    waitPostgreSQL retryPolicyDefault defaultConnectInfo+    putStrLn "Yay, the PostgreSQL server is ready to accept commands!"+```++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.+ ## See also  - [wait-for](https://github.com/eficode/wait-for) is a popular shell script with the same objectives as this library.
network-wait.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.5.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack  name:           network-wait-version:        0.1.0.0+version:        0.1.1.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@@ -25,6 +25,11 @@   type: git   location: https://github.com/mbg/network-wait +flag postgres+  description: Enable Postgres support.+  manual: True+  default: False+ library   exposed-modules:       Network.Wait@@ -38,6 +43,12 @@     , exceptions     , network     , retry+  if flag(postgres)+    build-depends:+        postgresql-simple+  if flag(postgres)+    exposed-modules:+        Network.Wait.PostgreSQL   default-language: Haskell2010  test-suite network-wait-test@@ -57,4 +68,32 @@     , retry     , tasty     , tasty-hunit+  if flag(postgres)+    build-depends:+        postgresql-simple+  default-language: Haskell2010++test-suite network-wait-test-postgres+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_network_wait+  hs-source-dirs:+      test-postgres+  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(postgres)+    buildable: True+  else+    buildable: False   default-language: Haskell2010
src/Network/Wait.hs view
@@ -13,14 +13,20 @@ -- to start out with e.g. `waitTcp` or `waitSocket` initially and move -- on to the more feature-rich variants if you need their functionality. module Network.Wait (+    -- * TCP     waitTcp,     waitTcpVerbose,     waitTcpVerboseFormat,     waitTcpWith,++    -- * Sockets     waitSocket,     waitSocketVerbose,     waitSocketVerboseFormat,-    waitSocketWith+    waitSocketWith,++    -- * Utility+    recoveringWith ) where  -------------------------------------------------------------------------------@@ -130,10 +136,7 @@     :: (MonadIO m, MonadMask m)     => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> AddrInfo -> m () waitSocketWith hs policy addr =-    -- apply the retry policy to the following code, with the combinations of-    -- the `skipAsyncExceptions`, given, and default handlers. The order of-    -- the handlers matters as they are checked in order.-    recovering policy (skipAsyncExceptions <> hs <> [defHandler])$ \_ ->+    recoveringWith hs policy $     -- all of the networking code runs in IO     liftIO $     -- we want to make sure that we close the socket after every attempt;@@ -143,6 +146,28 @@     where         initSocket =             socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)++-- | `recoveringWith` @extraHandlers retryPolicy action@ will attempt to+-- run @action@. If the @action@ fails, @retryPolicy@ is used+-- to determine whether (and how often) this function should attempt to+-- retry @action@. 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.+recoveringWith+    :: (MonadIO m, MonadMask m)+    => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> m () -> m ()+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+    -- the handlers matters as they are checked in order.+    recovering policy (skipAsyncExceptions <> hs <> [defHandler]) $+    -- we want to make sure that we close the socket after every attempt;+    -- `bracket` will re-throw any error afterwards+        const action+    where         -- our default handler, which works with any exception derived from         -- `SomeException`, and signals that we should retry if allowed by         -- the retry policy
+ src/Network/Wait/PostgreSQL.hs view
@@ -0,0 +1,87 @@+-------------------------------------------------------------------------------+-- network-wait+-- Copyright 2022 Michael B. Gale (github@michael-gale.co.uk)+-------------------------------------------------------------------------------++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | This module exports variants of the functions from "Network.Wait"+-- specialised for PostgreSQL servers. In addition to checking whether a+-- connection can be established, the functions in this module also check+-- whether the PostgreSQL server is ready to accept commands.+module Network.Wait.PostgreSQL (+    waitPostgreSql,+    waitPostgreSqlVerbose,+    waitPostgreSqlVerboseFormat,+    waitPostgreSqlWith+) where++-------------------------------------------------------------------------------++import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Retry++import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.Internal++import Network.Wait++-------------------------------------------------------------------------------++-- | `waitPostgreSql` @retryPolicy connectInfo@ is a variant of+-- `waitPostgresWith` which does not install any additional handlers.+waitPostgreSql+    :: (MonadIO m, MonadMask m)+    => RetryPolicyM m -> ConnectInfo -> m ()+waitPostgreSql = waitPostgreSqlWith []++-- | `waitPostgreSqlVerbose` @outputHandler retryPolicy connectInfo@ is a variant+-- of `waitPostgreSqlVerboseFormat` which catches all exceptions derived from+-- `SomeException` and formats retry attempt information using `defaultLogMsg`+-- before passing the resulting `String` to @out@.+waitPostgreSqlVerbose+    :: (MonadIO m, MonadMask m)+    => (String -> m ()) -> RetryPolicyM m -> ConnectInfo -> m ()+waitPostgreSqlVerbose out =+    waitPostgreSqlVerboseFormat @SomeException $+    \b ex st -> out $ defaultLogMsg b ex st++-- | `waitPostgreSqlVerboseFormat` @outputHandler retryPolicy connectInfo@ is a+-- variant of `waitPostgreSqlWith` which installs an extra handler based on+-- `logRetries` which passes status information for each retry attempt+-- to @outputHandler@.+waitPostgreSqlVerboseFormat+    :: forall e m . (MonadIO m, MonadMask m, Exception e)+    => (Bool -> e -> RetryStatus -> m ())+    -> RetryPolicyM m+    -> ConnectInfo+    -> m ()+waitPostgreSqlVerboseFormat out = waitPostgreSqlWith [h]+    where h = logRetries (const $ pure True) out++-- | `waitPostgreSqlWith` @extraHandlers retryPolicy connectInfo@ will attempt+-- to connect to the PostgreSQL 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.+waitPostgreSqlWith+    :: (MonadIO m, MonadMask m)+    => [RetryStatus -> Handler m Bool] -> RetryPolicyM m -> ConnectInfo -> m ()+waitPostgreSqlWith hs policy info =+    recoveringWith hs policy $+    liftIO $+    bracket (connect info) close $ \con -> do+        rs <- query_ @[Int] con "SELECT 1;"+        unless (rs == [[1]]) $ throwM $+            fatalError "Unexpected result for SELECT 1."++-------------------------------------------------------------------------------
+ test-postgres/Spec.hs view
@@ -0,0 +1,46 @@+-------------------------------------------------------------------------------+-- network-wait+-- Copyright 2022 Michael B. Gale (github@michael-gale.co.uk)+-------------------------------------------------------------------------------++{-# LANGUAGE TypeApplications #-}++import Control.Monad.Catch+import Control.Retry++import Database.PostgreSQL.Simple++import Test.Tasty+import Test.Tasty.HUnit++import Network.Wait.PostgreSQL++-------------------------------------------------------------------------------++tests :: TestTree+tests = testGroup "Network.Wait.PostgreSQL"+    [ testCase "Can't connect to server that doesn't exist" $ do+        res <- try @IO @SomeException $+            waitPostgreSql retryPolicyDefault defaultConnectInfo{+                connectHost = "doesnotexist"+            }++        case res of+            Left _ -> pure ()+            Right _ -> assertFailure "`waitPostgreSql` did not fail"+    , testCase "Can connect to server that does exist" $ do+            let policy = limitRetries 5 <> exponentialBackoff (2*1000*1000)+            res <- try @IO @SomeException $+                waitPostgreSqlVerbose putStrLn policy defaultConnectInfo++            case res of+                Left ex -> assertFailure $+                    "`waitPostgreSql` caused an exception: " <> show ex+                Right _ -> pure ()+    ]++-- | `main` is the entry point to this test suite.+main :: IO ()+main = defaultMain tests++-------------------------------------------------------------------------------