diff --git a/amazonka-test.cabal b/amazonka-test.cabal --- a/amazonka-test.cabal +++ b/amazonka-test.cabal @@ -1,67 +1,66 @@ -name: amazonka-test -version: 1.6.1 -synopsis: Common functionality for Amazonka library test-suites. -homepage: https://github.com/brendanhay/amazonka -bug-reports: https://github.com/brendanhay/amazonka/issues -license: MPL-2.0 -license-file: LICENSE -author: Brendan Hay -maintainer: Brendan Hay -copyright: Copyright (c) 2013-2017 Brendan Hay -category: Network, AWS, Cloud, Distributed Computing -build-type: Simple -extra-source-files: README.md -cabal-version: >= 1.10 +cabal-version: 2.2 +name: amazonka-test +version: 2.0 +synopsis: Common functionality for Amazonka library test-suites. +homepage: https://github.com/brendanhay/amazonka +bug-reports: https://github.com/brendanhay/amazonka/issues +license: MPL-2.0 +license-file: LICENSE +author: Brendan Hay +maintainer: + Brendan Hay , Jack Kelly +copyright: Copyright (c) 2013-2023 Brendan Hay +category: AWS +build-type: Simple +extra-source-files: README.md description: - Common functionality depended upon by test suites of the various @amazonka-*@ - service libraries. - . - The external interface of this library is stable with respect to the - downstream Amazonka libraries, only, and as such is not suitable - for use in non-Amazonka projects. + Common functionality depended upon by test suites of the various @amazonka-*@ + service libraries. + . + The external interface of this library is stable with respect to the + downstream Amazonka libraries, only, and as such is not suitable + for use in non-Amazonka projects. source-repository head - type: git - location: git://github.com/brendanhay/amazonka.git - subdir: test + type: git + location: git://github.com/brendanhay/amazonka.git + subdir: lib/amazonka-test library - default-language: Haskell2010 - hs-source-dirs: src - - ghc-options: - -Wall - -fwarn-incomplete-uni-patterns - -fwarn-incomplete-record-updates + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: + -Wall -fwarn-incomplete-uni-patterns + -fwarn-incomplete-record-updates - exposed-modules: - Test.AWS.Assert - , Test.AWS.Diff - , Test.AWS.Fixture - , Test.AWS.Orphans - , Test.AWS.Prelude - , Test.AWS.TH + exposed-modules: + Test.Amazonka.Assert + Test.Amazonka.Diff + Test.Amazonka.Fixture + Test.Amazonka.Orphans + Test.Amazonka.Prelude + Test.Amazonka.TH - build-depends: - aeson >= 0.8 - , amazonka-core == 1.6.1.* - , base >= 4.7 && < 5 - , bifunctors >= 4.1 - , bytestring >= 0.9 - , case-insensitive >= 1.2 - , conduit >= 1.1 - , conduit-extra >= 1.1 - , groom >= 0.1.1 - , http-client >= 0.4.9 - , http-types >= 0.8 - , process >= 1.2 - , resourcet >= 1.1 - , tasty >= 0.10 - , tasty-hunit >= 0.9 - , template-haskell >= 2.5 - , temporary >= 1.2 - , text >= 1.1 - , time >= 1.2 - , unordered-containers >= 0.2.5 - , yaml >= 0.8.7 + build-depends: + , aeson >=1.3 + , amazonka-core ^>=2.0 + , base >=4.12 && <5 + , bifunctors >=4.1 + , bytestring >=0.10.8 + , case-insensitive >=1.2 + , conduit >=1.1 + , conduit-extra >=1.1 + , groom >=0.1.1 + , http-client >=0.5 + , http-types >=0.8 + , process >=1.2 + , resourcet >=1.1 + , tasty >=0.10 + , tasty-hunit >=0.9 + , template-haskell >=2.5 + , temporary >=1.2 + , text >=1.1 + , time >=1.9 + , unordered-containers >=0.2.5 + , yaml >=0.8.7 diff --git a/src/Test/AWS/Assert.hs b/src/Test/AWS/Assert.hs deleted file mode 100644 --- a/src/Test/AWS/Assert.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | --- Module : Test.AWS.Assert --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Assert where - -import Control.Monad -import Test.AWS.Diff -import Test.AWS.Orphans () -import Test.Tasty.HUnit - -assertDiff :: (Eq a, Show a) => String -> a -> Either String a -> Assertion -assertDiff _ _ (Left m) = assertFailure m -assertDiff n e (Right a) = unless (e == a) (msg >>= assertFailure) - where - msg = do - d <- diff e a - return $! "[Expected]:\n" ++ show e - ++ "\n[" ++ n ++ "]:\n" ++ show a - ++ "\n" - ++ d diff --git a/src/Test/AWS/Diff.hs b/src/Test/AWS/Diff.hs deleted file mode 100644 --- a/src/Test/AWS/Diff.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | --- Module : Test.AWS.Diff --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Diff where - -import System.IO -import System.IO.Temp -import System.Process -import Text.Groom - --- | Display the difference between two Haskell values, --- with control over the diff parameters. -diff :: (Show a, Show b) => a -> b -> IO String -diff e a = - withSystemTempFile "diff_expect" $ \ep eh -> - withSystemTempFile "diff_actual" $ \ap ah -> do - hPutStrLn eh (groom e) >> hClose eh - hPutStrLn ah (groom a) >> hClose ah - (_, !out, !err) - <- readProcessWithExitCode "diff" ["-U", "3", ep, ap] [] - return (out ++ "\n" ++ err) diff --git a/src/Test/AWS/Fixture.hs b/src/Test/AWS/Fixture.hs deleted file mode 100644 --- a/src/Test/AWS/Fixture.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Test.AWS.Fixture --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Fixture where - -import Control.Monad.Trans.Resource -import Data.Aeson -import Data.Bifunctor -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Conduit.Binary as Conduit -import qualified Data.HashMap.Strict as Map -import Data.List (sortBy) -import Data.Ord -import Data.Proxy -import Data.Time -import qualified Data.Yaml as YAML -import Network.AWS.Data.ByteString -import qualified Network.AWS.Data.Map as Map -import Network.AWS.Lens (trying, (<&>)) -import Network.AWS.Prelude -import Network.HTTP.Client.Internal hiding (Proxy, Request, Response) -import qualified Network.HTTP.Client.Internal as Client -import Network.HTTP.Types -import Test.AWS.Assert -import Test.AWS.Orphans () -import Test.AWS.TH -import Test.Tasty -import Test.Tasty.HUnit - -res :: (AWSRequest a, Eq (Rs a), Show (Rs a)) - => TestName - -> FilePath - -> Service - -> Proxy a - -> Rs a - -> TestTree -res n f s p e = testCase n $ - LBS.readFile f - >>= testResponse s p - >>= assertDiff f e - -req :: (AWSRequest a, Eq a, Show a) - => TestName - -> FilePath - -> a - -> TestTree -req n f e = testCase n $ do - a <- YAML.decodeFileEither f - e' <- expected - assertDiff f e' (first show a) - where - expected = do - let x = sgRequest (rqSign (request e) auth NorthVirginia time) - b <- sink (requestBody x) - return $! mkReq - (method x) - (path x) - (queryString x) - (requestHeaders x) - b - - sink = \case - RequestBodyLBS lbs -> pure (toBS lbs) - RequestBodyBS bs -> pure bs - RequestBodyBuilder _ b -> pure (toBS b) - _ -> fail "Streaming body not supported." - -testResponse :: forall a. AWSRequest a - => Service - -> Proxy a - -> LazyByteString - -> IO (Either String (Rs a)) -testResponse s p lbs = do - y <- trying _Error $ runResourceT (response l s p rs) - return $! first show (snd <$> y) - where - l _ _ = return () - - rs = Client.Response - { responseStatus = status200 - , responseVersion = http11 - , responseHeaders = mempty - , responseBody = Conduit.sourceLbs lbs - , responseCookieJar = mempty - , responseClose' = ResponseClose (pure ()) - } - -auth :: AuthEnv -auth = AuthEnv "access" "secret" Nothing Nothing - -time :: UTCTime -time = $(mkTime "2009-10-28T22:32:00Z") - -data Req = Req - { _method :: Method - , _path :: ByteString - , _query :: ByteString - , _headers :: [Header] - , _body :: ByteString - } deriving (Eq, Show, Generic) - -mkReq :: Method -> ByteString -> ByteString -> [Header] -> ByteString -> Req -mkReq m p q h = Req m p q (sortKeys h) - -instance FromJSON Req where - parseJSON = withObject "req" $ \o -> mkReq - <$> o .: "method" - <*> (o .:? "path" .!= "/") - <*> (o .:? "query" .!= mempty) - <*> (o .:? "headers" .!= mempty <&> Map.toList . Map.toMap) - <*> (o .:? "body" .!= mempty) - -sortKeys :: Ord a => [(a, b)] -> [(a, b)] -sortKeys = sortBy (comparing fst) diff --git a/src/Test/AWS/Orphans.hs b/src/Test/AWS/Orphans.hs deleted file mode 100644 --- a/src/Test/AWS/Orphans.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Module : Test.AWS.Orphans --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Orphans where - -import Data.Aeson -import Network.AWS.Prelude - -instance FromJSON ByteString where - parseJSON = withText "bytestring" (either fail pure . fromText) diff --git a/src/Test/AWS/Prelude.hs b/src/Test/AWS/Prelude.hs deleted file mode 100644 --- a/src/Test/AWS/Prelude.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | --- Module : Test.AWS.Prelude --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Prelude - ( module Export - ) where - -import Data.Traversable as Export (traverse) -import Network.AWS.Lens as Export -import Test.AWS.Assert as Export -import Test.AWS.Orphans as Export () -import Test.AWS.TH as Export -import Test.Tasty as Export (TestTree, testGroup) -import Test.Tasty.HUnit as Export (testCase) diff --git a/src/Test/AWS/TH.hs b/src/Test/AWS/TH.hs deleted file mode 100644 --- a/src/Test/AWS/TH.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Module : Test.AWS.TH --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Test.AWS.TH where - -import Control.Applicative -import Data.Time -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Network.AWS.Data.Text -import Network.AWS.Data.Time -import Network.AWS.Lens (view) - -mkTime :: Text -> Q Exp -mkTime x = - case fromText x :: Either String ISO8601 of - Left e -> error (show e) - Right t -> [|view _Time t|] - -instance Lift (Time a) where - lift (Time x) = AppE (ConE (mkName "Time")) <$> lift x - -instance Lift UTCTime where - lift (UTCTime x y) = do - x' <- lift x - y' <- lift y - return $ AppE (AppE (ConE (mkName "UTCTime")) x') y' - -instance Lift DiffTime where - lift x = [|toEnum $(lift (fromEnum x))|] - -instance Lift Day where - lift x = [|toEnum $(lift (fromEnum x))|] diff --git a/src/Test/Amazonka/Assert.hs b/src/Test/Amazonka/Assert.hs new file mode 100644 --- /dev/null +++ b/src/Test/Amazonka/Assert.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Test.Amazonka.Assert +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Assert where + +import Control.Monad +import Test.Amazonka.Diff +import Test.Amazonka.Orphans () +import Test.Tasty.HUnit + +assertDiff :: (Eq a, Show a) => String -> a -> Either String a -> Assertion +assertDiff _ _ (Left m) = assertFailure m +assertDiff n e (Right a) = unless (e == a) (msg >>= assertFailure) + where + msg = do + d <- diff e a + return $! + "[Expected]:\n" + ++ show e + ++ "\n[" + ++ n + ++ "]:\n" + ++ show a + ++ "\n" + ++ d diff --git a/src/Test/Amazonka/Diff.hs b/src/Test/Amazonka/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Test/Amazonka/Diff.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Test.Amazonka.Diff +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Diff where + +import System.IO +import System.IO.Temp +import System.Process +import Text.Groom + +-- | Display the difference between two Haskell values, +-- with control over the diff parameters. +diff :: (Show a, Show b) => a -> b -> IO String +diff e a = + withSystemTempFile "diff_expect" $ \ep eh -> + withSystemTempFile "diff_actual" $ \ap ah -> do + hPutStrLn eh (groom e) >> hClose eh + hPutStrLn ah (groom a) >> hClose ah + (_, !out, !err) <- + readProcessWithExitCode "diff" ["-U", "3", ep, ap] [] + return (out ++ "\n" ++ err) diff --git a/src/Test/Amazonka/Fixture.hs b/src/Test/Amazonka/Fixture.hs new file mode 100644 --- /dev/null +++ b/src/Test/Amazonka/Fixture.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Test.Amazonka.Fixture +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Fixture where + +import Amazonka.Core +import Amazonka.Data +import Amazonka.Prelude +import Control.Monad.Trans.Resource +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI +import qualified Data.Conduit.Binary as Conduit +import qualified Data.List as List +import qualified Data.Ord as Ord +import qualified Data.Text.Encoding as Text +import qualified Data.Yaml as YAML +import qualified Network.HTTP.Client.Internal as Client +import Network.HTTP.Types (Method) +import qualified Network.HTTP.Types as HTTP +import Test.Amazonka.Assert +import Test.Amazonka.Orphans () +import Test.Amazonka.TH +import Test.Tasty +import Test.Tasty.HUnit + +res :: + (AWSRequest a, Eq (AWSResponse a), Show (AWSResponse a)) => + TestName -> + FilePath -> + Service -> + Proxy a -> + AWSResponse a -> + TestTree +res n f s p e = + testCase n $ + LBS.readFile f + >>= testResponse s p + >>= assertDiff f e + +req :: + forall a. + (AWSRequest a, Eq a, Show a) => + TestName -> + FilePath -> + a -> + TestTree +req n f e = testCase n $ do + a <- YAML.decodeFileEither f + e' <- expected + assertDiff f e' (first show a) + where + expected = do + let x = signedRequest (requestSign (request id e) auth NorthVirginia time) + b <- sink (Client.requestBody x) + return $! + mkReq + (Client.method x) + (Client.path x) + (Client.queryString x) + (Client.requestHeaders x) + b + + sink = \case + Client.RequestBodyLBS lbs -> pure (toBS lbs) + Client.RequestBodyBS bs -> pure bs + Client.RequestBodyBuilder _ b -> pure (toBS b) + _ -> fail "Streaming body not supported." + +testResponse :: + forall a. + AWSRequest a => + Service -> + Proxy a -> + ByteStringLazy -> + IO (Either String (AWSResponse a)) +testResponse s p lbs = do + y <- runResourceT (response pure s p rs) + + return $! first show (Client.responseBody <$> y) + where + rs = + Client.Response + { responseStatus = HTTP.status200, + responseVersion = HTTP.http11, + responseHeaders = mempty, + responseBody = Conduit.sourceLbs lbs, + responseCookieJar = mempty, + responseClose' = Client.ResponseClose (pure ()) + } + +auth :: AuthEnv +auth = AuthEnv "access" "secret" Nothing Nothing + +time :: UTCTime +time = $(mkTime "2009-10-28T22:32:00Z") + +data Req = Req + { _method :: Method, + _path :: ByteString, + _query :: ByteString, + _headers :: [Header], + _body :: ByteString + } + deriving (Eq, Show, Generic) + +mkReq :: Method -> ByteString -> ByteString -> [Header] -> ByteString -> Req +mkReq m p q h = Req m p q (sortKeys h) + +instance FromJSON Req where + parseJSON = withObject "req" $ \o -> do + headers <- o .:? "headers" .!= mempty + + mkReq + <$> o .: "method" + <*> (o .:? "path" .!= "/") + <*> (o .:? "query" .!= mempty) + <*> pure (map (bimap (CI.mk . Text.encodeUtf8) Text.encodeUtf8) headers) + <*> (o .:? "body" .!= mempty) + +sortKeys :: Ord a => [(a, b)] -> [(a, b)] +sortKeys = List.sortBy (Ord.comparing fst) diff --git a/src/Test/Amazonka/Orphans.hs b/src/Test/Amazonka/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Test/Amazonka/Orphans.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Test.Amazonka.Orphans +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Orphans where + +import Amazonka.Data +import Data.Aeson + +instance FromJSON ByteString where + parseJSON = withText "bytestring" (either fail pure . fromText) diff --git a/src/Test/Amazonka/Prelude.hs b/src/Test/Amazonka/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Test/Amazonka/Prelude.hs @@ -0,0 +1,19 @@ +-- | +-- Module : Test.Amazonka.Prelude +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Prelude + ( module Export, + ) +where + +import Amazonka.Core.Lens.Internal as Export +import Data.Traversable as Export (traverse) +import Test.Amazonka.Assert as Export +import Test.Amazonka.Orphans as Export () +import Test.Amazonka.TH as Export +import Test.Tasty as Export (TestTree, testGroup) +import Test.Tasty.HUnit as Export (testCase) diff --git a/src/Test/Amazonka/TH.hs b/src/Test/Amazonka/TH.hs new file mode 100644 --- /dev/null +++ b/src/Test/Amazonka/TH.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Test.Amazonka.TH +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.TH where + +import Amazonka.Core.Lens.Internal (view) +import Amazonka.Data +import Data.Time (Day (..), DiffTime, UTCTime (..)) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +mkTime :: Text -> Q Exp +mkTime x = + case fromText x :: Either String ISO8601 of + Left e -> error (show e) + Right t -> [|view _Time t|] + +deriving instance Lift (Time a) + +deriving instance Lift UTCTime + +deriving instance Lift Day + +-- DiffTime's constructor is not exported, so use a manual instance. +-- +-- Note: An entire valid instance must be duplicated inside CPP to +-- otherwise the ormolu formatter will erroneously rewrite it. +#if MIN_VERSION_template_haskell(2,16,0) +instance Lift DiffTime where + liftTyped x = [||toEnum $$(liftTyped (fromEnum x))||] +#else +instance Lift DiffTime where + lift x = [|toEnum $(lift (fromEnum x))|] +#endif