mismi-core (empty) → 0.0.1
raw patch · 14 files changed
+993/−0 lines, 14 filesdep +amazonkadep +amazonka-coredep +base
Dependencies added: amazonka, amazonka-core, base, bytestring, exceptions, hedgehog, http-client, http-types, lens, mismi-core, mismi-core-test, mismi-kernel, mismi-p, mmorph, mtl, resourcet, retry, text, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- mismi-core.cabal +127/−0
- src/Mismi.hs +7/−0
- src/Mismi/Amazonka.hs +16/−0
- src/Mismi/Control.hs +355/−0
- src/Mismi/Data.hs +88/−0
- src/Mismi/Environment.hs +131/−0
- test/Test/IO/Mismi/Control.hs +78/−0
- test/Test/Mismi.hs +61/−0
- test/Test/Mismi/Data.hs +22/−0
- test/Test/Mismi/Gen.hs +38/−0
- test/test-io.hs +18/−0
- test/test.hs +17/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+## Version 0.0.1 (2018-12-16)++- Replace `p` submodule with `mismi-p`+- Upgrade tests from QuickCheck to hedgehog+- Remove `amazonka`, `x`, `disorder` and `twine` submodules
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2017, Nick Hibberd <nhibberd@gmail.com>, All Rights Reserved.++Copyright 2017, Ambiata, All Rights Reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ 3. Neither the name of the copyright holder nor the names of+ its contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ mismi-core.cabal view
@@ -0,0 +1,127 @@+version: 0.0.1++name:+ mismi-core+author:+ Nick Hibberd+maintainer:+ Nick Hibberd <nhibberd@gmail.com>+homepage:+ https://github.com/nhibberd/mismi+bug-reports:+ https://github.com/nhibberd/mismi/issues+synopsis:+ AWS Library+description:+ mismi-core is a library designed on top of amazonka and+ amazonka-core that aims to provide useful functions around safety,+ functionality and robustness, for example: retrying, bracketing,+ enabling debugging and runner functions with error handling.+category:+ AWS+license:+ BSD3+license-file:+ LICENSE+cabal-version:+ >= 1.8+build-type:+ Simple+tested-with:+ GHC == 8.2.2+ , GHC == 8.4.3+extra-source-files:+ CHANGELOG.md++library+ build-depends:+ base >= 3 && < 5+ , mismi-kernel+ , mismi-p+ , amazonka >= 1.5 && < 1.7+ , amazonka-core >= 1.5 && < 1.7+ , bytestring >= 0.10 && < 0.11+ , exceptions >= 0.7 && < 0.11+ , http-client >= 0.4.18 && < 0.6+ , http-types >= 0.9 && < 0.13+ , lens >= 4.8 && < 4.17+ , mtl >= 2.1 && < 2.3+ , resourcet >= 1.1 && < 1.3+ , retry == 0.7.*+ , text >= 1.1 && < 1.3+ , transformers >= 0.3.1 && < 0.6++ ghc-options:+ -Wall++ hs-source-dirs:+ src+++ exposed-modules:+ Mismi+ Mismi.Amazonka+ Mismi.Control+ Mismi.Data+ Mismi.Environment+++test-suite test+ type:+ exitcode-stdio-1.0++ main-is:+ test.hs++ ghc-options:+ -Wall -threaded -O2++ hs-source-dirs:+ test++ other-modules:+ Test.Mismi+ Test.Mismi.Data+ Test.Mismi.Gen+++ build-depends:+ base+ , mismi-core+ , mismi-p+ , mmorph >= 1.0 && < 1.2+ , amazonka-core >= 1.5 && < 1.7+ , hedgehog+ , transformers >= 0.3.1 && < 0.6+++test-suite test-io+ type:+ exitcode-stdio-1.0++ main-is:+ test-io.hs++ ghc-options:+ -Wall -threaded -O2++ hs-source-dirs:+ test++ other-modules:+ Test.Mismi+ Test.Mismi.Data+ Test.Mismi.Gen+ Test.IO.Mismi.Control++ build-depends:+ base+ , mismi-core+ , mismi-core-test+ , mismi-p+ , mmorph >= 1.0 && < 1.2+ , amazonka-core >= 1.5 && < 1.7+ , hedgehog+ , exceptions >= 0.7 && < 0.11+ , resourcet >= 1.1 && < 1.3+ , transformers >= 0.3.1 && < 0.6
+ src/Mismi.hs view
@@ -0,0 +1,7 @@+module Mismi (+ module X+ ) where++import Mismi.Control as X+import Mismi.Data as X+import Mismi.Environment as X
+ src/Mismi/Amazonka.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Mismi.Amazonka (+ module A+ ) where++import Network.AWS as A+import Network.AWS.Auth as A+import Network.AWS.Data as A+import Network.AWS.Error as A+import Network.AWS.Waiter as A+#if MIN_VERSION_amazonka(1,4,0)+import Network.AWS.Prelude as A+#else+import Network.AWS.Prelude as A hiding ((&))+#endif
+ src/Mismi/Control.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Mismi.Control (+ A.AWS+ , A.Error+ , A.AccessKey+ , A.SecretKey+ , A.SessionToken+ , A.Region (..)+ , runAWS+ , runAWST+ , runAWSTWith+ , runAWSTWithRegion+ , rawRunAWS+ , runAWSWithRegion+ , newEnvFromCreds+ , awsBracket+ , awsBracket_+ , unsafeRunAWS+ , renderError+ , onStatus+ , onStatus_+ , handle404+ , handle403+ , handle301+ , setServiceRetry+ , setRetry+ , configureRetries+ , handleServiceError+ , withRetries+ , withRetriesOf+ , throwOrRetry+ , throwOrRetryOf+ ) where++import Control.Exception (IOException)+import Control.Lens (over, (.~), (^.), (^?))+import Control.Monad.Catch (Handler (..), MonadCatch, MonadMask, SomeException, bracket, catch, fromException, throwM, try)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (ask, local)+import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, runExceptT)+import Control.Retry (RetryPolicyM, RetryStatus)+import Control.Retry (applyPolicy, fullJitterBackoff, recovering, rsIterNumber)++import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Lazy as BL+import Data.Text.Encoding (decodeUtf8)++import Mismi.Environment (discoverAWSEnvWithRegion)++import Network.AWS hiding (runAWS)+import qualified Network.AWS as A+import Network.AWS.Data+import Network.AWS.Error++import Network.HTTP.Client (HttpException (..))+#if MIN_VERSION_http_client(0,5,0)+import Network.HTTP.Client (HttpExceptionContent (..), responseStatus, responseTimeoutMicro)+#endif+import Network.HTTP.Client.Internal (mResponseTimeout)+import Network.HTTP.Types.Status (Status (..))+import qualified Network.HTTP.Types as HTTP++import P++runAWST :: Env -> (Error -> e) -> ExceptT e AWS a -> ExceptT e IO a+runAWST e err action =+ runAWSTWith (runAWS e) err action++runAWSTWithRegion :: Region -> (Error -> e) -> ExceptT e AWS a -> ExceptT e IO a+runAWSTWithRegion r err action =+ runAWSTWith (runAWSWithRegion r) err action++runAWSTWith :: (forall b. AWS b -> ExceptT Error IO b) -> (Error -> e) -> ExceptT e AWS a -> ExceptT e IO a+runAWSTWith run err action =+ joinErrors id err $ mapExceptT run action++joinErrors :: (Functor m, Monad m) => (x -> z) -> (y -> z) -> ExceptT x (ExceptT y m) a -> ExceptT z m a+joinErrors f g =+ let+ first' h =+ either (Left . h) Right++ second' =+ fmap+ in+ mapExceptT (fmap (join . second' (first' f) . first' g)) . runExceptT++runAWS :: (MonadIO m, MonadCatch m) => Env -> AWS a -> ExceptT Error m a+runAWS e'' =+ let+ e' = over envManager (\m -> m { mResponseTimeout =+#if MIN_VERSION_http_client(0,5,0)+ responseTimeoutMicro 60000000+#else+ Just 60000000+#endif+ }) e''+ e = configureRetries 5 e'+ in+ ExceptT . try . liftIO . rawRunAWS e++runAWSWithRegion :: (MonadIO m, MonadCatch m) => Region -> AWS a -> ExceptT Error m a+runAWSWithRegion r a = do+ e <- liftIO $ discoverAWSEnvWithRegion r+ runAWS e a++newEnvFromCreds :: (Applicative m, MonadIO m, MonadCatch m) => Region -> AccessKey -> SecretKey -> Maybe SessionToken -> m Env+newEnvFromCreds r ak sk st = do+#if MIN_VERSION_amazonka(1,4,4)+ e <- newEnv $ case st of+ Nothing ->+ FromKeys ak sk+ Just st' ->+ FromSession ak sk st'+ pure $ e & envRegion .~ r+#else+ newEnv r $ case st of+ Nothing ->+ FromKeys ak sk+ Just st' ->+ FromSession ak sk st'+#endif++rawRunAWS :: Env -> AWS a -> IO a+rawRunAWS e =+ runResourceT . A.runAWS e++awsBracket :: AWS a -> (a -> AWS c) -> (a -> AWS b) -> AWS b+awsBracket r f a = do+ e <- ask+ liftIO $ bracket (unsafeRunAWS e r) (unsafeRunAWS e . f) (unsafeRunAWS e . a)++awsBracket_ :: AWS a -> AWS c -> AWS b -> AWS b+awsBracket_ r f a =+ awsBracket r (const f) (const a)++unsafeRunAWS :: Env -> AWS a -> IO a+unsafeRunAWS e a =+ either throwM pure =<< runExceptT (runAWS e a)++renderError :: Error -> Text+renderError =+ decodeUtf8 . BL.toStrict . toLazyByteString . build++setServiceRetry :: Retry -> AWS a -> AWS a+setServiceRetry r =+ local (override (serviceRetry .~ r))++setRetry :: Int -> AWS a -> AWS a+setRetry =+ local . configureRetries++withRetries :: (MonadCatch m, MonadMask m, MonadIO m) => Int -> m a -> m a+withRetries =+ withRetriesOf (fullJitterBackoff 500000)++withRetriesOf :: (MonadCatch m, MonadMask m, MonadIO m) => RetryPolicyM m -> Int -> m a -> m a+withRetriesOf policy n action = do+ recovering policy [httpCondition n, ioCondition n] $ \_ ->+ action++httpCondition :: Applicative m => Int -> RetryStatus -> Handler m Bool+httpCondition n s =+ Handler $ \(e :: HttpException) ->+ pure $+ if rsIterNumber s > n+ then False+ else checkException e False++ioCondition :: Applicative m => Int -> RetryStatus -> Handler m Bool+ioCondition n s =+ Handler $ \(_ :: IOException) ->+ pure $ rsIterNumber s < n++throwOrRetry ::+ (MonadCatch m, MonadMask m, MonadIO m)+ => Int+ -> SomeException+ -> RetryStatus+ -> m RetryStatus+throwOrRetry =+ throwOrRetryOf (fullJitterBackoff 500000)++throwOrRetryOf ::+ (MonadCatch m, MonadMask m, MonadIO m)+ => RetryPolicyM m+ -> Int+ -> SomeException+ -> RetryStatus+ -> m RetryStatus+throwOrRetryOf policy n ex0 s0 =+ let+ recover = \case+ [] ->+ throwM ex0++ h0 : hs ->+ case h0 s0 of+ Handler h ->+ case fromException ex0 of+ Nothing ->+ recover hs++ Just ex -> do+ ok <- h ex+ if ok then do+ ms <- applyPolicy policy s0+ case ms of+ Nothing ->+ throwM ex++ Just s ->+ pure s++ else+ throwM ex+ in+ recover [httpCondition n, ioCondition n]++configureRetries :: Int -> Env -> Env+configureRetries i e = e & envRetryCheck .~ err+ where+ err c _ | c >= i = False+ err c v =+ checkException v $ (e ^. envRetryCheck) c v++checkException :: HttpException -> Bool -> Bool+checkException v f =+ case v of+#if MIN_VERSION_http_client(0,5,0)+ InvalidUrlException _ _ ->+ False+ HttpExceptionRequest _req content ->+ case content of+ NoResponseDataReceived ->+ True+ StatusCodeException resp _ ->+ let status = responseStatus resp in+ status == HTTP.status500 || status == HTTP.status503+ ResponseTimeout ->+ True+ ConnectionTimeout ->+ True+ ConnectionFailure _ ->+ True+ ResponseBodyTooShort _ _ ->+ True+ InternalException _ ->+ True+ InvalidStatusLine _ ->+ True+ InvalidHeader _ ->+ True+ ProxyConnectException _ _ _ ->+ True+ WrongRequestBodyStreamSize _ _ ->+ True+ InvalidChunkHeaders ->+ True+ IncompleteHeaders ->+ True+ HttpZlibException _ ->+ True++ TooManyRedirects _ ->+ False+ OverlongHeaders ->+ False+ TlsNotSupported ->+ False+ InvalidDestinationHost _ ->+ False+ InvalidProxyEnvironmentVariable _ _ ->+ False++ _ ->+ f+#else+ NoResponseDataReceived ->+ True+ StatusCodeException status _ _ ->+ status == HTTP.status500 || status == HTTP.status503+ FailedConnectionException _ _ ->+ True+ FailedConnectionException2 _ _ _ _ ->+ True+ TlsException _ ->+ True+ InternalIOException _ ->+ True+ HandshakeFailed ->+ True+ ResponseTimeout ->+ True+ ResponseBodyTooShort _ _ ->+ True+ _ ->+ f+#endif++handle404 :: AWS a -> AWS (Maybe a)+handle404 =+ handleStatus HTTP.status404++handle403 :: AWS a -> AWS (Maybe a)+handle403 =+ handleStatus HTTP.status403++handle301 :: AWS a -> AWS (Maybe a)+handle301 =+ handleStatus HTTP.status301++handleStatus :: Status -> AWS a -> AWS (Maybe a)+handleStatus s m =+ fmap Just m `catch` \(e :: Error) ->+ if e ^? httpStatus == Just s then return Nothing else throwM e++-- | Return a result code depending on the HTTP status+onStatus :: (Status -> Maybe r) -> AWS a -> AWS (Either r a)+onStatus f m =+ fmap Right m `catch` \(e :: Error) ->+ case e ^? httpStatus >>= f of+ Just r1 ->+ return (Left r1)+ Nothing ->+ throwM e++-- | Return a result code depending on the HTTP status+-- for an AWS action returning no value+onStatus_ :: r -> (Status -> Maybe r) -> AWS () -> AWS r+onStatus_ r f m =+ fmap (const r) m `catch` \(e :: Error) ->+ case e ^? httpStatus >>= f of+ Just r1 ->+ return r1+ Nothing ->+ throwM e++handleServiceError :: (ServiceError -> Bool) -> (ServiceError -> a) -> AWS a -> AWS a+handleServiceError f pass action =+ action `catch` \(e :: Error) ->+ case e of+ ServiceError se ->+ if f se+ then pure $ pass se+ else throwM e+ SerializeError _ ->+ throwM e+ TransportError _ ->+ throwM e
+ src/Mismi/Data.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP #-}+module Mismi.Data (+ module Mismi.Kernel.Data+ , fromMismiRegion+ , toMismiRegion+ ) where++import Control.Monad.Trans.AWS (Region (..))++import Mismi.Kernel.Data+++fromMismiRegion :: MismiRegion -> Region+fromMismiRegion r =+ case r of+ IrelandRegion ->+ Ireland+ FrankfurtRegion ->+ Frankfurt+ TokyoRegion ->+ Tokyo+ SingaporeRegion ->+ Singapore+ SydneyRegion ->+ Sydney+ BeijingRegion ->+ Beijing+ NorthVirginiaRegion ->+ NorthVirginia+ NorthCaliforniaRegion ->+ NorthCalifornia+ OregonRegion ->+ Oregon+ GovCloudRegion ->+ GovCloud+ GovCloudFIPSRegion ->+ GovCloudFIPS+ SaoPauloRegion ->+ SaoPaulo+ OhioRegion ->+ Ohio+ SeoulRegion ->+ Seoul+ MumbaiRegion ->+ Mumbai+ MontrealRegion ->+ Montreal+ LondonRegion ->+ London++toMismiRegion :: Region -> MismiRegion+toMismiRegion r =+ case r of+ Ireland ->+ IrelandRegion+ Frankfurt ->+ FrankfurtRegion+ Tokyo ->+ TokyoRegion+ Singapore ->+ SingaporeRegion+ Sydney ->+ SydneyRegion+ Beijing ->+ BeijingRegion+ NorthVirginia ->+ NorthVirginiaRegion+ NorthCalifornia ->+ NorthCaliforniaRegion+ Oregon ->+ OregonRegion+ GovCloud ->+ GovCloudRegion+ GovCloudFIPS ->+ GovCloudFIPSRegion+ SaoPaulo ->+ SaoPauloRegion+ Ohio ->+ OhioRegion+ Seoul ->+ SeoulRegion+ Mumbai ->+ MumbaiRegion+ Montreal ->+ MontrealRegion+ London ->+ LondonRegion
+ src/Mismi/Environment.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Mismi.Environment (+ Env+ , Region (..)+ , RegionError (..)+ , Debugging (..)+ , getRegionFromEnv+ , getDebugging+ , setDebugging+ , renderRegionError+ , discoverAWSEnv+ , discoverAWSEnvWithRegion+ , discoverAWSEnvRetry+ , discoverAWSEnvWithRegionRetry+ , catchAuthError+ , newMismiEnv+ ) where++import Control.Lens ((.~))+import Control.Monad.Catch (Handler (..), MonadCatch (..), MonadThrow (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.AWS (Credentials (..), Region (..))+import Control.Monad.Trans.AWS (Env, envLogger, envRegion, newEnv)+import Control.Monad.Trans.AWS (LogLevel (..), Logger, newLogger)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT, throwE)+import Control.Retry (RetryPolicyM, constantDelay, limitRetries, recovering)++import qualified Data.Text as T+import Data.Typeable (Typeable)++import Network.AWS.Auth (AuthError (..))+import Network.AWS.Data (fromText)++import P++import System.Environment (lookupEnv)+import System.IO (IO, stderr)++data RegionError =+ MissingRegion+ | UnknownRegion Text+ deriving (Eq, Show, Typeable)++data Debugging =+ DebugEnabled Logger+ | DebugDisabled+++getRegionFromEnv :: (MonadIO m, MonadThrow m) => ExceptT RegionError m Region+getRegionFromEnv = do+ mr <- liftIO $ lookupEnv "AWS_DEFAULT_REGION"+ case mr of+ Nothing ->+ throwE MissingRegion+ Just a ->+ case fromText $ T.pack a of+ Left e ->+ throwE $ UnknownRegion (T.pack e)+ Right r ->+ pure r++getDebugging :: MonadIO m => m Debugging+getDebugging = do+ d <- liftIO $ lookupEnv "AWS_DEBUG"+ maybe+ (return DebugDisabled)+ (\s ->+ case T.pack s of+ "true" ->+ return . DebugEnabled =<< newLogger Trace stderr+ "1" ->+ return . DebugEnabled =<< newLogger Trace stderr+ _ ->+ return DebugDisabled)+ d++setDebugging :: Debugging -> Env -> Env+setDebugging d e =+ case d of+ DebugEnabled lgr ->+ e & envLogger .~ lgr+ DebugDisabled ->+ e++discoverAWSEnv :: ExceptT RegionError IO Env+discoverAWSEnv =+ discoverAWSEnvRetry $ limitRetries 1 <> constantDelay 200000++discoverAWSEnvWithRegion :: Region -> IO Env+discoverAWSEnvWithRegion r =+ flip discoverAWSEnvWithRegionRetry r $ limitRetries 1 <> constantDelay 200000++discoverAWSEnvRetry :: RetryPolicyM IO -> ExceptT RegionError IO Env+discoverAWSEnvRetry retry = do+ r <- getRegionFromEnv+ lift $ discoverAWSEnvWithRegionRetry retry r++discoverAWSEnvWithRegionRetry :: RetryPolicyM IO -> Region -> IO Env+discoverAWSEnvWithRegionRetry rpol r = do+ d <- getDebugging+ e <- recovering rpol [(\_ -> Handler catchAuthError)] $ \_ -> newMismiEnv r Discover+ pure $ setDebugging d e+++newMismiEnv :: (Applicative m, MonadIO m, MonadCatch m) => Region -> Credentials -> m Env+newMismiEnv r c = do+ e <- newEnv c+ pure $ e & envRegion .~ r++catchAuthError :: AuthError -> IO Bool+-- MDS sometimes has transient failures.+catchAuthError (RetrievalError _) = pure True+-- 'MissingFileError' is rethrown from 'getAuth' in+-- 'Discover' mode if 'isEC2' (which queries the MDS) returns+-- 'False'.+-- FIXME(sio): fix this upstream so we can distinguish between+-- legit 'MissingFileError's and MDS failures.+catchAuthError (MissingFileError _) = pure True+-- Everything else is unlikely to be transient.+catchAuthError _ = pure False++renderRegionError :: RegionError -> Text+renderRegionError e =+ case e of+ UnknownRegion r ->+ "Unknown region: " <> r+ MissingRegion ->+ "Environment variable AWS_DEFAULT_REGION was not found"
+ test/Test/IO/Mismi/Control.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.IO.Mismi.Control (tests) where++import Control.Monad.Catch (throwM, catchIOError)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Resource (register)++import Data.IORef (modifyIORef, newIORef, readIORef)++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Mismi.Control (awsBracket)++import P++import System.IO.Error (userError)++import Test.Mismi (testAWS, liftAWS, runAWSDefaultRegion)++prop_bracket :: Property+prop_bracket =+ property $ do+ l <- forAll $ Gen.list (Range.linear 0 100) (Gen.text (Range.linear 0 50) Gen.alphaNum)+ final <- forAll $ Gen.text (Range.linear 1 10) Gen.alphaNum+ action <- forAll $ Gen.text (Range.linear 1 10) Gen.alphaNum++ ref <- liftIO $ newIORef l+ let+ after' = (flip modifyIORef (final :))+ action' = (flip modifyIORef (action :))+ liftIO . runAWSDefaultRegion $ awsBracket (liftIO $ return ref) (liftIO . after') (liftIO . action')+ result <- liftIO $ readIORef ref+ result === final : action : l++prop_bracket_catch :: Property+prop_bracket_catch =+ property $ do+ l <- forAll $ Gen.list (Range.linear 0 100) (Gen.text (Range.linear 0 50) Gen.alphaNum)+ final <- forAll $ Gen.text (Range.linear 1 10) Gen.alphaNum++ ref <- liftIO $ newIORef l+ let+ after' = (flip modifyIORef (final :))+ action' = const $ throwM (userError "")+ liftIO . runAWSDefaultRegion $+ awsBracket (liftIO $ return ref) (liftIO . after') (liftIO . action') `catchIOError` (const $ return ())+ result <- liftIO $ readIORef ref+ result === final : l+++prop_testAWS :: Property+prop_testAWS =+ withTests 1 . testAWS $+ pure ()++prop_testAWS_PropertyT :: Property+prop_testAWS_PropertyT =+ withTests 1 . property . liftAWS $ do+ False === False+ True === True+++prop_finalizer :: Property+prop_finalizer =+ property $ do+ ref <- liftIO $ newIORef (0 :: Int)+ liftIO . runAWSDefaultRegion $ do+ void $ register (modifyIORef ref (const $ 1))+ result <- liftIO $ readIORef ref+ result === 1++tests :: IO Bool+tests =+ checkSequential $$(discover)
+ test/Test/Mismi.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Test.Mismi (+ testAWS+ , liftAWS+ , enableTests+ , runAWSDefaultRegion+ ) where++import Control.Monad.Morph (hoist)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (runExceptT)++import Hedgehog++import Mismi+import Mismi.Control (unsafeRunAWS)++import P+import Prelude (String)++import System.Environment (lookupEnv)+import System.IO (IO)++testAWS :: AWS () -> Property+testAWS action =+ property $+ liftAWS (lift action)++liftAWS :: PropertyT AWS a -> PropertyT IO a+liftAWS =+ hoist runAWSDefaultRegion++-- Default to Sydney for tests only, production should fail without the environment variable+runAWSDefaultRegion :: AWS a -> IO a+runAWSDefaultRegion a = do+ r <- either (const $ pure Sydney) pure =<< runExceptT getRegionFromEnv+ e <- discoverAWSEnvWithRegion r+ unsafeRunAWS e a++-- Environment variable to lookup, tests to run when it is set to+-- false and tests to run when when it is set to true (or missing).+enableTests :: String -> [IO Bool] -> [IO Bool] -> IO [IO Bool]+enableTests k false true = do+ d <- lookupEnv k+ pure $ bool false true $+ maybe+ True+ (\s ->+ case s of+ "true" ->+ True+ "1" ->+ True+ "false" ->+ False+ "0" ->+ False+ _ ->+ True)+ d
+ test/Test/Mismi/Data.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.Mismi.Data where++import Hedgehog++import Mismi.Data++import P++import qualified Test.Mismi.Gen as Gen++prop_tripping_region :: Property+prop_tripping_region =+ property $ do+ region <- forAll Gen.genRegion+ region === fromMismiRegion (toMismiRegion region)++tests :: IO Bool+tests =+ checkSequential $$(discover)
+ test/Test/Mismi/Gen.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Test.Mismi.Gen (+ genRegion+ , genAccessKey+ , genSecretKey+ , genSessionToken+ ) where++import Network.AWS.Types (SessionToken (..), SecretKey (..), AccessKey (..))++import Mismi.Control (Region (..))++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import P++genRegion :: Gen Region+genRegion =+ -- Shorter list than possible, aws doesn't support all potential Regions.+ Gen.element [Ireland, Tokyo, Singapore, Sydney, NorthCalifornia, Oregon, NorthVirginia]++genAccessKey :: Gen AccessKey+genAccessKey =+ AccessKey <$>+ Gen.utf8 (Range.linear 0 50) Gen.alphaNum++genSecretKey :: Gen SecretKey+genSecretKey =+ SecretKey <$>+ Gen.utf8 (Range.linear 0 50) Gen.alphaNum++genSessionToken :: Gen SessionToken+genSessionToken =+ SessionToken <$>+ Gen.utf8 (Range.linear 0 50) Gen.alphaNum
+ test/test-io.hs view
@@ -0,0 +1,18 @@+import Control.Monad (unless)++import System.Exit (exitFailure)+import System.IO (BufferMode(..), hSetBuffering, stdout, stderr)++import qualified Test.Mismi as Mismi+import qualified Test.IO.Mismi.Control++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ results <- sequence =<< Mismi.enableTests "AWS_TEST" [] [+ Test.IO.Mismi.Control.tests+ ]++ unless (and results) exitFailure
+ test/test.hs view
@@ -0,0 +1,17 @@+import Control.Monad (unless)++import System.Exit (exitFailure)+import System.IO (BufferMode(..), hSetBuffering, stdout, stderr)++import qualified Test.Mismi.Data++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ results <- sequence [+ Test.Mismi.Data.tests+ ]++ unless (and results) exitFailure