network-wait (empty) → 0.1.0.0

raw patch · 7 files changed

+340/−0 lines, 7 filesdep +basedep +exceptionsdep +networksetup-changed

Dependencies added: base, exceptions, network, network-simple, network-wait, retry, tasty, tasty-hunit

Files

• ChangeLog.md +5/−0
• LICENSE +21/−0
• README.md +24/−0
• Setup.hs +2/−0
• network-wait.cabal +60/−0
• src/Network/Wait.hs +151/−0
• test/Spec.hs +77/−0

@@ -0,0 +1,5 @@+# Changelog for network-wait++## 0.1.0++- First release

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Michael B. Gale++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,24 @@+# 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++All functions provided by this library work with retry policies from [`Control.Retry`](https://hackage.haskell.org/package/retry) which provide good control over the retry behaviour. To wait for a PostgreSQL server to become available on the same machine:++```haskell+import Control.Retry+import Network.Wait++main :: IO ()+main = do+    waitTcp retryPolicyDefault "localhost" "5432"+    putStrLn "Yay, the server is available!"+```++The haddock documentation for this library contains more examples.++## See also++- [wait-for](https://github.com/eficode/wait-for) is a popular shell script with the same objectives as this library.+- The [port-utils](https://hackage.haskell.org/package/port-utils) package has some functions for waiting on TCP servers to become available, with a fixed timeout.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,60 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.5.+--+-- see: https://github.com/sol/hpack++name:           network-wait+version:        0.1.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+homepage:       https://github.com/mbg/network-wait#readme+bug-reports:    https://github.com/mbg/network-wait/issues+author:         Michael B. Gale+maintainer:     github@michael-gale.co.uk+copyright:      2022 Michael B. Gale+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/mbg/network-wait++library+  exposed-modules:+      Network.Wait+  other-modules:+      Paths_network_wait+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , exceptions+    , network+    , retry+  default-language: Haskell2010++test-suite network-wait-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_network_wait+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , exceptions+    , network+    , network-simple+    , network-wait+    , retry+    , tasty+    , tasty-hunit+  default-language: Haskell2010

@@ -0,0 +1,151 @@+-------------------------------------------------------------------------------+-- network-wait+-- Copyright 2022 Michael B. Gale (github@michael-gale.co.uk)+-------------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | This module contains computations which wait for some networked service+-- to become available, subject to some retry policy from "Control.Retry".+-- The `waitSocketWith` function is the most general function exported by+-- this module, but several variants exist for convenience. You may wish+-- 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 (+    waitTcp,+    waitTcpVerbose,+    waitTcpVerboseFormat,+    waitTcpWith,+    waitSocket,+    waitSocketVerbose,+    waitSocketVerboseFormat,+    waitSocketWith+) where++-------------------------------------------------------------------------------++import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Retry++import Network.Socket++-------------------------------------------------------------------------------++-- | `waitTcp` @retryPolicy hostName serviceName@ is a variant of `waitTcpWith`+-- which does not install any additional handlers.+--+-- > waitTcp retryPolicyDefault "localhost" "80"+waitTcp+    :: (MonadIO m, MonadMask m)+    => RetryPolicyM m -> HostName -> ServiceName -> m ()+waitTcp = waitTcpWith []++-- | `waitTcpVerbose` @outputHandler retryPolicy addrInfo@ is a variant+-- of `waitTcpVerboseFormat` which catches all exceptions derived from+-- `SomeException` and formats retry attempt information using `defaultLogMsg`+-- before passing the resulting `String` to @out@.+--+-- > waitTcpVerbose putStrLn retryPolicyDefault "localhost" "80"+waitTcpVerbose+    :: (MonadIO m, MonadMask m)+    => (String -> m ()) -> RetryPolicyM m -> HostName -> ServiceName -> m ()+waitTcpVerbose out =+    waitTcpVerboseFormat @SomeException $+    \b ex st -> out $ defaultLogMsg b ex st++-- | `waitTcpVerboseFormat` @outputHandler retryPolicy addrInfo@ is a+-- variant of `waitTcpWith` which installs an extra handler based on+-- `logRetries` which passes status information for each retry attempt+-- to @outputHandler@.+--+-- > waitTcpVerboseFormat @SomeException+-- >      (\b ex st -> putStrLn $ defaultLogMsg b ex st)+-- >      retryPolicyDefault "localhost" "80"+waitTcpVerboseFormat+    :: forall e m . (MonadIO m, MonadMask m, Exception e)+    => (Bool -> e -> RetryStatus -> m ())+    -> RetryPolicyM m+    -> HostName+    -> ServiceName+    -> m ()+waitTcpVerboseFormat out = waitTcpWith [h]+    where h = logRetries (const $ pure True) out++-- | `waitTcpWith` @extraHandlers retryPolicy hostName serviceName@ is a+-- variant of `waitSocketWith` which constructs a suitable `AddrInfo` value+-- for a TCP socket from @hostName@ and @serviceName@.+waitTcpWith+    :: (MonadIO m, MonadMask m)+    => [RetryStatus -> Handler m Bool]+    -> RetryPolicyM m -> HostName -> ServiceName -> m ()+waitTcpWith hs policy host port = do+    let hints = defaultHints { addrSocketType = Stream }+    addr <- head <$> liftIO (getAddrInfo (Just hints) (Just host) (Just port))+    waitSocketWith hs policy addr++-- | `waitSocket` @retryPolicy addrInfo@ is a variant of `waitSocketWith` which+-- does not install any additional exception handlers.+waitSocket+    :: (MonadIO m, MonadMask m)+    => RetryPolicyM m -> AddrInfo -> m ()+waitSocket = waitSocketWith []++-- | `waitSocketVerbose` @outputHandler retryPolicy addrInfo@ is a variant+-- of `waitSocketVerboseFormat` which catches all exceptions derived from+-- `SomeException` and formats retry attempt information using `defaultLogMsg`+-- before passing the resulting `String` to @out@.+waitSocketVerbose+    :: (MonadIO m, MonadMask m)+    => (String -> m ()) -> RetryPolicyM m -> AddrInfo -> m ()+waitSocketVerbose out =+    waitSocketVerboseFormat @SomeException $+    \b ex st -> out $ defaultLogMsg b ex st++-- | `waitSocketVerboseFormat` @outputHandler retryPolicy addrInfo@ is a+-- variant of `waitSocketWith` which installs an extra handler based on+-- `logRetries` which passes status information for each retry attempt+-- to @outputHandler@.+waitSocketVerboseFormat+    :: forall e m . (MonadIO m, MonadMask m, Exception e)+    => (Bool -> e -> RetryStatus -> m ())+    -> RetryPolicyM m+    -> AddrInfo+    -> m ()+waitSocketVerboseFormat out = waitSocketWith [h]+    where h = logRetries (const $ pure True) out++-- | `waitSocketWith` @extraHandlers retryPolicy addrInfo@ will attempt to+-- connect to @addrInfo@. If the connection 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.+waitSocketWith+    :: (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])$ \_ ->+    -- all of the networking code runs in IO+    liftIO $+    -- 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)+    where+        initSocket =+            socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+        -- our default handler, which works with any exception derived from+        -- `SomeException`, and signals that we should retry if allowed by+        -- the retry policy+        defHandler _ = Handler $ \(_ :: SomeException) -> pure True++-------------------------------------------------------------------------------

@@ -0,0 +1,77 @@+-------------------------------------------------------------------------------+-- network-wait+-- Copyright 2022 Michael B. Gale (github@michael-gale.co.uk)+-------------------------------------------------------------------------------++{-# LANGUAGE TypeApplications #-}++import Control.Concurrent+import Control.Monad.Catch+import Control.Retry++import Test.Tasty+import Test.Tasty.HUnit++import Network.Simple.TCP+import Network.Wait++-------------------------------------------------------------------------------++-- | `withServer` @delay action@ runs @action@ while asynchronously setting up+-- a TCP server on @localhost:5999@ with a @delay@ microseconds delay. The TCP+-- server will accept exactly one connection before shutting down.+withServer :: Int -> IO () -> IO ()+withServer delay k = do+    let initSocket = do+            (sock, _) <- bindSock (Host "localhost") "5999"+            listenSock sock 1+            pure sock++    tid <- forkIO $ do+        -- wait before starting the server+        threadDelay delay+        -- initialise the server, accept one connection, and shut down+        bracket initSocket closeSock $ \sock ->+            accept sock $ \(client,_) -> closeSock client++    -- run the computation that depends on the server+    k++    -- kill the server thread, if it is still alive+    killThread tid++tests :: TestTree+tests = testGroup "network-wait"+    [ testCase "Can't connect to service that doesn't exist" $ do+        res <- try @IO @SomeException $+            waitTcp retryPolicyDefault "localhost" "5999"++        case res of+            Left _ -> pure ()+            Right _ -> assertFailure "`waitTcp` did not fail"+    , testCase "Can connect to service that does exist" $+        withServer 0 $ do+            res <- try @IO @SomeException $+                waitTcp retryPolicyDefault "localhost" "5999"++            case res of+                Left ex -> assertFailure $+                    "`waitTcp` caused an exception: " <> show ex+                Right _ -> pure ()+    , testCase "Can connect to service after delay" $+        withServer 500000 $ do+            let policy = limitRetries 5 <> exponentialBackoff (60*1000)+            res <- try @IO @SomeException $+                waitTcp policy "localhost" "5999"++            case res of+                Left ex -> assertFailure $+                    "`waitTcp` caused an exception: " <> show ex+                Right _ -> pure ()+    ]++-- | `main` is the entry point to this test suite.+main :: IO ()+main = defaultMain tests++-------------------------------------------------------------------------------