{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module: Aws.Test.Utils
-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.
-- License: MIT
-- Maintainer: Lars Kuhtz <lars@alephcloud.com>
-- Stability: experimental
--
-- Utils for testing the Haskell bindings for Amazon Web Services (AWS)
--
module Aws.Test.Utils
(
-- * Parameters
testDataPrefix
-- * General Utils
, sshow
, tryT
, retryT
, retryT_
, testData
) where
import Control.Applicative
import Control.Concurrent (threadDelay)
import qualified Control.Exception.Lifted as LE
import Control.Error hiding (syncIO)
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Data.Dynamic (Dynamic)
import Data.Monoid
import Data.String
import qualified Data.Text as T
import System.Exit (ExitCode)
-- -------------------------------------------------------------------------- --
-- Static Test parameters
--
-- | This prefix is used for the IDs and names of all entities that are
-- created in the AWS account.
--
testDataPrefix :: IsString a => a
testDataPrefix = "__TEST_AWSHASKELLBINDINGS__"
-- -------------------------------------------------------------------------- --
-- General Utils
-- | Catches all exceptions except for asynchronous exceptions found in base.
--
tryT :: MonadBaseControl IO m => m a -> EitherT T.Text m a
tryT = fmapLT (T.pack . show) . syncIO
-- | Lifted Version of 'syncIO' form "Control.Error.Util".
--
syncIO :: MonadBaseControl IO m => m a -> EitherT LE.SomeException m a
syncIO a = EitherT $ LE.catches (Right <$> a)
[ LE.Handler $ \e -> LE.throw (e :: LE.ArithException)
, LE.Handler $ \e -> LE.throw (e :: LE.ArrayException)
, LE.Handler $ \e -> LE.throw (e :: LE.AssertionFailed)
, LE.Handler $ \e -> LE.throw (e :: LE.AsyncException)
, LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnMVar)
, LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnSTM)
, LE.Handler $ \e -> LE.throw (e :: LE.Deadlock)
, LE.Handler $ \e -> LE.throw (e :: Dynamic)
, LE.Handler $ \e -> LE.throw (e :: LE.ErrorCall)
, LE.Handler $ \e -> LE.throw (e :: ExitCode)
, LE.Handler $ \e -> LE.throw (e :: LE.NestedAtomically)
, LE.Handler $ \e -> LE.throw (e :: LE.NoMethodError)
, LE.Handler $ \e -> LE.throw (e :: LE.NonTermination)
, LE.Handler $ \e -> LE.throw (e :: LE.PatternMatchFail)
, LE.Handler $ \e -> LE.throw (e :: LE.RecConError)
, LE.Handler $ \e -> LE.throw (e :: LE.RecSelError)
, LE.Handler $ \e -> LE.throw (e :: LE.RecUpdError)
, LE.Handler $ return . Left
]
testData :: (IsString a, Monoid a) => a -> a
testData a = testDataPrefix <> a
retryT :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m a
retryT n f = snd <$> retryT_ n f
retryT_ :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m (Int, a)
retryT_ n f = go 1
where
go x
| x >= n = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) ((x,) <$> f)
| otherwise = ((x,) <$> f) `catchT` \_ -> do
liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))
go (succ x)
sshow :: (Show a, IsString b) => a -> b
sshow = fromString . show