summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBrendanHay <>2017-11-15 08:13:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-11-15 08:13:00 (GMT)
commitdb664137fce7eb42124926358014d9e3cb64b42b (patch)
tree5d0b8207d40b2034b506f407e413d8ffd60b8bcc
parentc18b08dfc7cb308922acc34e9a6850f455e5f5d9 (diff)
version 1.5.01.5.0
-rw-r--r--amazonka-core.cabal28
-rw-r--r--src/Network/AWS/Compat/Locale.hs4
-rw-r--r--src/Network/AWS/Compat/Time.hs4
-rw-r--r--src/Network/AWS/Data/Base64.hs4
-rw-r--r--src/Network/AWS/Data/Body.hs4
-rw-r--r--src/Network/AWS/Data/ByteString.hs4
-rw-r--r--src/Network/AWS/Data/Crypto.hs10
-rw-r--r--src/Network/AWS/Data/Headers.hs4
-rw-r--r--src/Network/AWS/Data/JSON.hs4
-rw-r--r--src/Network/AWS/Data/List1.hs4
-rw-r--r--src/Network/AWS/Data/Log.hs4
-rw-r--r--src/Network/AWS/Data/Map.hs10
-rw-r--r--src/Network/AWS/Data/Numeric.hs4
-rw-r--r--src/Network/AWS/Data/Path.hs4
-rw-r--r--src/Network/AWS/Data/Query.hs27
-rw-r--r--src/Network/AWS/Data/Sensitive.hs15
-rw-r--r--src/Network/AWS/Data/Text.hs4
-rw-r--r--src/Network/AWS/Data/Time.hs11
-rw-r--r--src/Network/AWS/Data/XML.hs90
-rw-r--r--src/Network/AWS/Endpoint.hs4
-rw-r--r--src/Network/AWS/Error.hs68
-rw-r--r--src/Network/AWS/Lens.hs4
-rw-r--r--src/Network/AWS/Pager.hs24
-rw-r--r--src/Network/AWS/Prelude.hs11
-rw-r--r--src/Network/AWS/Request.hs4
-rw-r--r--src/Network/AWS/Response.hs4
-rw-r--r--src/Network/AWS/Sign/V2.hs4
-rw-r--r--src/Network/AWS/Sign/V2Header.hs87
-rw-r--r--src/Network/AWS/Sign/V2Header/Base.hs159
-rw-r--r--src/Network/AWS/Sign/V4.hs4
-rw-r--r--src/Network/AWS/Sign/V4/Base.hs24
-rw-r--r--src/Network/AWS/Sign/V4/Chunked.hs46
-rw-r--r--src/Network/AWS/Types.hs174
-rw-r--r--src/Network/AWS/Waiter.hs17
-rw-r--r--test/Main.hs27
-rw-r--r--test/Test/AWS/Arbitrary.hs62
-rw-r--r--test/Test/AWS/Data/Base64.hs4
-rw-r--r--test/Test/AWS/Data/List.hs4
-rw-r--r--test/Test/AWS/Data/Maybe.hs4
-rw-r--r--test/Test/AWS/Data/Numeric.hs4
-rw-r--r--test/Test/AWS/Data/Path.hs4
-rw-r--r--test/Test/AWS/Data/Query.hs51
-rw-r--r--test/Test/AWS/Data/Time.hs4
-rw-r--r--test/Test/AWS/Error.hs6
-rw-r--r--test/Test/AWS/Sign/V2Header/BaseSpec.hs278
-rw-r--r--test/Test/AWS/Sign/V4.hs27
-rw-r--r--test/Test/AWS/Sign/V4/Chunked.hs101
-rw-r--r--test/Test/AWS/Util.hs4
48 files changed, 1193 insertions, 260 deletions
diff --git a/amazonka-core.cabal b/amazonka-core.cabal
index 03ce729..1d669c0 100644
--- a/amazonka-core.cabal
+++ b/amazonka-core.cabal
@@ -1,13 +1,13 @@
name: amazonka-core
-version: 1.4.5
+version: 1.5.0
synopsis: Core data types and functionality for Amazonka libraries.
homepage: https://github.com/brendanhay/amazonka
bug-reports: https://github.com/brendanhay/amazonka/issues
-license: OtherLicense
+license: MPL-2.0
license-file: LICENSE
author: Brendan Hay
-maintainer: Brendan Hay <brendan.g.hay@gmail.com>
-copyright: Copyright (c) 2013-2016 Brendan Hay
+maintainer: Brendan Hay <brendan.g.hay+amazonka@gmail.com>
+copyright: Copyright (c) 2013-2017 Brendan Hay
category: Network, AWS, Cloud, Distributed Computing
build-type: Simple
extra-source-files: README.md
@@ -24,6 +24,7 @@ description:
source-repository head
type: git
location: git://github.com/brendanhay/amazonka.git
+ subdir: core
flag old-locale
description: Use old-locale and time < 1.5
@@ -33,7 +34,11 @@ library
default-language: Haskell2010
hs-source-dirs: src
- ghc-options: -Wall
+ ghc-options:
+ -Wall
+ -fwarn-incomplete-uni-patterns
+ -fwarn-incomplete-record-updates
+ -funbox-strict-fields
exposed-modules:
Network.AWS.Compat.Locale
@@ -61,6 +66,8 @@ library
, Network.AWS.Prelude
, Network.AWS.Request
, Network.AWS.Response
+ , Network.AWS.Sign.V2Header
+ , Network.AWS.Sign.V2Header.Base
, Network.AWS.Sign.V2
, Network.AWS.Sign.V4
, Network.AWS.Types
@@ -126,9 +133,12 @@ test-suite tests
, Test.AWS.Data.Maybe
, Test.AWS.Data.Numeric
, Test.AWS.Data.Path
+ , Test.AWS.Data.Query
, Test.AWS.Data.Time
, Test.AWS.Error
+ , Test.AWS.Sign.V2Header.BaseSpec
, Test.AWS.Sign.V4
+ , Test.AWS.Sign.V4.Chunked
, Test.AWS.Util
build-depends:
@@ -137,12 +147,16 @@ test-suite tests
, base
, bytestring
, case-insensitive
+ , conduit
+ , data-ordlist
+ , http-conduit
, http-types
+ , lens
+ , QuickCheck
+ , quickcheck-unicode
, tasty
, tasty-hunit
, tasty-quickcheck
, template-haskell
, text
, time
- , QuickCheck
- , quickcheck-unicode
diff --git a/src/Network/AWS/Compat/Locale.hs b/src/Network/AWS/Compat/Locale.hs
index b4d4bf9..8b4ac6f 100644
--- a/src/Network/AWS/Compat/Locale.hs
+++ b/src/Network/AWS/Compat/Locale.hs
@@ -2,9 +2,9 @@
-- |
-- Module : Network.AWS.Compat.Locale
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Compat/Time.hs b/src/Network/AWS/Compat/Time.hs
index 6ebabc0..b288f5c 100644
--- a/src/Network/AWS/Compat/Time.hs
+++ b/src/Network/AWS/Compat/Time.hs
@@ -2,9 +2,9 @@
-- |
-- Module : Network.AWS.Compat.Time
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/Base64.hs b/src/Network/AWS/Data/Base64.hs
index b973eef..cc59b83 100644
--- a/src/Network/AWS/Data/Base64.hs
+++ b/src/Network/AWS/Data/Base64.hs
@@ -4,9 +4,9 @@
-- |
-- Module : Network.AWS.Data.Base64
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/Body.hs b/src/Network/AWS/Data/Body.hs
index 33f3514..13c6dab 100644
--- a/src/Network/AWS/Data/Body.hs
+++ b/src/Network/AWS/Data/Body.hs
@@ -12,9 +12,9 @@
-- |
-- Module : Network.AWS.Data.Body
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/ByteString.hs b/src/Network/AWS/Data/ByteString.hs
index d0e8b32..5238631 100644
--- a/src/Network/AWS/Data/ByteString.hs
+++ b/src/Network/AWS/Data/ByteString.hs
@@ -7,9 +7,9 @@
-- |
-- Module : Network.AWS.Data.ByteString
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
diff --git a/src/Network/AWS/Data/Crypto.hs b/src/Network/AWS/Data/Crypto.hs
index ab4ce40..037a15d 100644
--- a/src/Network/AWS/Data/Crypto.hs
+++ b/src/Network/AWS/Data/Crypto.hs
@@ -5,9 +5,9 @@
-- |
-- Module : Network.AWS.Data.Crypto
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -18,6 +18,7 @@ module Network.AWS.Data.Crypto
, digestToBase
-- * Algorithms
+ , hmacSHA1
, hmacSHA256
, hashSHA256
, hashMD5
@@ -50,6 +51,11 @@ digestToBS = convert
digestToBase :: ByteArrayAccess a => Base -> a -> ByteString
digestToBase = convertToBase
+
+-- | Apply an HMAC sha1 with the given secret to the given value.
+hmacSHA1 :: (ByteArrayAccess a, ByteArray b) => a -> b -> HMAC SHA1
+hmacSHA1 = hmac
+
hmacSHA256 :: (ByteArrayAccess a, ByteArray b) => a -> b -> HMAC SHA256
hmacSHA256 = hmac
diff --git a/src/Network/AWS/Data/Headers.hs b/src/Network/AWS/Data/Headers.hs
index 59ccecb..2780e34 100644
--- a/src/Network/AWS/Data/Headers.hs
+++ b/src/Network/AWS/Data/Headers.hs
@@ -6,9 +6,9 @@
-- |
-- Module : Network.AWS.Data.Headers
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/JSON.hs b/src/Network/AWS/Data/JSON.hs
index e0a3737..f1bb007 100644
--- a/src/Network/AWS/Data/JSON.hs
+++ b/src/Network/AWS/Data/JSON.hs
@@ -2,9 +2,9 @@
-- |
-- Module : Network.AWS.Data.JSON
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/List1.hs b/src/Network/AWS/Data/List1.hs
index 82fecc1..5c65943 100644
--- a/src/Network/AWS/Data/List1.hs
+++ b/src/Network/AWS/Data/List1.hs
@@ -7,9 +7,9 @@
-- |
-- Module : Network.AWS.Data.List1
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/Log.hs b/src/Network/AWS/Data/Log.hs
index 5febe6a..e9c020e 100644
--- a/src/Network/AWS/Data/Log.hs
+++ b/src/Network/AWS/Data/Log.hs
@@ -7,9 +7,9 @@
-- |
-- Module : Network.AWS.Data.Log
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/Map.hs b/src/Network/AWS/Data/Map.hs
index 892467d..a6be81a 100644
--- a/src/Network/AWS/Data/Map.hs
+++ b/src/Network/AWS/Data/Map.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RoleAnnotations #-}
@@ -9,9 +9,9 @@
-- |
-- Module : Network.AWS.Data.Map
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -23,14 +23,14 @@ module Network.AWS.Data.Map
, toQueryMap
) where
-import Control.DeepSeq
import Control.Applicative
+import Control.DeepSeq
import Data.Aeson
import Data.Bifunctor
import qualified Data.ByteString as BS
import qualified Data.CaseInsensitive as CI
import Data.Coerce
-import Data.Data (Data,Typeable)
+import Data.Data (Data, Typeable)
import Data.Foldable hiding (toList)
import Data.Hashable
import Data.HashMap.Strict (HashMap)
diff --git a/src/Network/AWS/Data/Numeric.hs b/src/Network/AWS/Data/Numeric.hs
index 1e5c326..47bccf0 100644
--- a/src/Network/AWS/Data/Numeric.hs
+++ b/src/Network/AWS/Data/Numeric.hs
@@ -5,9 +5,9 @@
-- |
-- Module : Network.AWS.Data.Numeric
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/Path.hs b/src/Network/AWS/Data/Path.hs
index 8fc4e1e..7ee864f 100644
--- a/src/Network/AWS/Data/Path.hs
+++ b/src/Network/AWS/Data/Path.hs
@@ -8,9 +8,9 @@
-- |
-- Module : Network.AWS.Data.Path
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/Query.hs b/src/Network/AWS/Data/Query.hs
index eee4741..0b23edb 100644
--- a/src/Network/AWS/Data/Query.hs
+++ b/src/Network/AWS/Data/Query.hs
@@ -11,9 +11,9 @@
-- |
-- Module : Network.AWS.Data.Query
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -25,6 +25,7 @@ import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import Data.Data
import Data.List (sort)
+import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.String
import qualified Data.Text.Encoding as Text
@@ -50,8 +51,26 @@ instance Monoid QueryString where
(l, r) -> QList [l, r]
instance IsString QueryString where
- fromString [] = mempty
- fromString xs = QPair (BS8.pack xs) (QValue Nothing)
+ fromString = parseQueryString . fromString
+ {-# INLINE fromString #-}
+
+parseQueryString :: ByteString -> QueryString
+parseQueryString bs
+ | BS8.null bs = mempty
+ | otherwise =
+ QList (map breakPair . filter (not . BS8.null) $ BS8.split '&' bs)
+ where
+ breakPair x =
+ case BS8.break (== '=') x of
+ ("", "") -> mempty
+ ("", v) -> stripValue v
+ (k, v) -> QPair k (stripValue v)
+
+ stripValue x =
+ case x of
+ "" -> QValue Nothing
+ "=" -> QValue Nothing
+ _ -> QValue (Just (fromMaybe x (BS8.stripPrefix "=" x)))
-- FIXME: use Builder
instance ToByteString QueryString where
diff --git a/src/Network/AWS/Data/Sensitive.hs b/src/Network/AWS/Data/Sensitive.hs
index 477fd1d..10f8f4e 100644
--- a/src/Network/AWS/Data/Sensitive.hs
+++ b/src/Network/AWS/Data/Sensitive.hs
@@ -1,12 +1,13 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Network.AWS.Data.Sensitive
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -17,9 +18,13 @@ import Data.Data (Data, Typeable)
import Data.Hashable
import Data.Monoid
import Data.String
+
import GHC.Generics (Generic)
+
+import Network.AWS.Data.Headers
import Network.AWS.Data.ByteString
import Network.AWS.Data.JSON
+import Network.AWS.Data.Log (ToLog (..))
import Network.AWS.Data.Query
import Network.AWS.Data.Text
import Network.AWS.Data.XML
@@ -30,7 +35,6 @@ newtype Sensitive a = Sensitive { desensitise :: a }
deriving
( Eq
, Ord
- , Read
, IsString
, Monoid
, Data
@@ -44,10 +48,11 @@ newtype Sensitive a = Sensitive { desensitise :: a }
, ToQuery
, ToJSON
, FromJSON
+ , ToHeader
)
-instance Show (Sensitive a) where
- show = const "******"
+instance Show (Sensitive a) where show = const "******"
+instance ToLog (Sensitive a) where build = const "******"
instance Hashable a => Hashable (Sensitive a)
instance NFData a => NFData (Sensitive a)
diff --git a/src/Network/AWS/Data/Text.hs b/src/Network/AWS/Data/Text.hs
index 8bf8326..22097e2 100644
--- a/src/Network/AWS/Data/Text.hs
+++ b/src/Network/AWS/Data/Text.hs
@@ -6,9 +6,9 @@
-- |
-- Module : Network.AWS.Data.Text
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Data/Time.hs b/src/Network/AWS/Data/Time.hs
index f8a3fac..23576ed 100644
--- a/src/Network/AWS/Data/Time.hs
+++ b/src/Network/AWS/Data/Time.hs
@@ -13,9 +13,9 @@
-- |
-- Module : Network.AWS.Data.Time
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -193,6 +193,9 @@ instance ToQuery ISO8601 where toQuery = toQuery . toBS
instance ToQuery BasicTime where toQuery = toQuery . toBS
instance ToQuery AWSTime where toQuery = toQuery . toBS
+instance ToQuery POSIX where
+ toQuery (Time t) = toQuery (truncate (utcTimeToPOSIXSeconds t) :: Integer)
+
instance ToXML RFC822 where toXML = toXMLText
instance ToXML ISO8601 where toXML = toXMLText
instance ToXML AWSTime where toXML = toXMLText
@@ -204,5 +207,5 @@ instance ToJSON AWSTime where toJSON = toJSONText
instance ToJSON BasicTime where toJSON = toJSONText
instance ToJSON POSIX where
- toJSON (Time t) = Number $
- scientific (truncate (utcTimeToPOSIXSeconds t) :: Integer) 0
+ toJSON (Time t) =
+ Number $ scientific (truncate (utcTimeToPOSIXSeconds t) :: Integer) 0
diff --git a/src/Network/AWS/Data/XML.hs b/src/Network/AWS/Data/XML.hs
index ee204f2..70f7b64 100644
--- a/src/Network/AWS/Data/XML.hs
+++ b/src/Network/AWS/Data/XML.hs
@@ -4,12 +4,13 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
-- |
-- Module : Network.AWS.Data.XML
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -17,24 +18,31 @@ module Network.AWS.Data.XML where
import Control.Applicative
import Control.Monad
+
import Data.Bifunctor
-import qualified Data.ByteString.Lazy as LBS
import Data.Conduit
import Data.Conduit.Lazy (lazyConsume)
-import qualified Data.Conduit.List as Conduit
import Data.Maybe
import Data.Monoid
import Data.Traversable (traverse)
import Data.XML.Types (Event (..))
+
import GHC.Exts
+
import Network.AWS.Data.ByteString
import Network.AWS.Data.Text
+
import Numeric.Natural
+
import System.IO.Unsafe (unsafePerformIO)
+
import Text.XML
-import qualified Text.XML.Stream.Render as Stream
import Text.XML.Unresolved (toEvents)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Conduit.List as Conduit
+import qualified Text.XML.Stream.Render as Stream
+
infixl 7 .@, .@?
(.@) :: FromXML a => [Node] -> Text -> Either String a
@@ -46,7 +54,7 @@ ns .@? n =
Left _ -> Right Nothing
Right xs -> parseXML xs
-infixr 7 @=
+infixr 7 @=, @@=
(@=) :: ToXML a => Name -> a -> XML
n @= x =
@@ -54,8 +62,13 @@ n @= x =
XNull -> XNull
xs -> XOne . NodeElement $ mkElement n xs
+(@@=) :: ToText a => Name -> a -> XML
+n @@= x = XAttr n (toText x)
+
decodeXML :: FromXML a => LazyByteString -> Either String a
-decodeXML = first show . parseLBS def >=> parseXML . elementNodes . documentRoot
+decodeXML lbs =
+ bimap show documentRoot (parseLBS def lbs)
+ >>= parseXML . childrenOf
-- The following is taken from xml-conduit.Text.XML which uses
-- unsafePerformIO anyway, with the following caveat:
@@ -129,27 +142,37 @@ maybeElement x =
-- declaration be consistent WRT to single nodes or lists of nodes.
data XML
= XNull
+ | XAttr Name Text
| XOne Node
- | XMany [Node]
+ | XMany [(Name, Text)] [Node]
deriving (Show)
instance Monoid XML where
mempty = XNull
mappend XNull XNull = XNull
- mappend a b = XMany (listXMLNodes a <> listXMLNodes b)
+ mappend a XNull = a
+ mappend XNull b = b
+ mappend a b =
+ XMany (listXMLAttributes a <> listXMLAttributes b)
+ (listXMLNodes a <> listXMLNodes b)
listXMLNodes :: XML -> [Node]
listXMLNodes = \case
- XNull -> []
- XOne n -> [n]
- XMany ns -> ns
+ XNull -> []
+ XAttr {} -> []
+ XOne n -> [n]
+ XMany _ ns -> ns
+
+listXMLAttributes :: XML -> [(Name, Text)]
+listXMLAttributes = \case
+ XNull -> []
+ XAttr n t -> [(n, t)]
+ XOne {} -> []
+ XMany as _ -> as
class ToXML a where
toXML :: a -> XML
-toXMLNodes :: ToXML a => a -> [Node]
-toXMLNodes = listXMLNodes . toXML
-
instance ToXML XML where
toXML = id
@@ -177,13 +200,14 @@ parseXMLText n = withContent n >=>
fromText
toXMLList :: (IsList a, ToXML (Item a)) => Name -> a -> XML
-toXMLList n = XMany . map (NodeElement . mkElement n) . toList
+toXMLList n = XMany [] . map (NodeElement . mkElement n) . toList
toXMLText :: ToText a => a -> XML
toXMLText = XOne . NodeContent . toText
mkElement :: ToXML a => Name -> a -> Element
-mkElement n = Element n mempty . listXMLNodes . toXML
+mkElement n (toXML -> x) =
+ Element n (fromList (listXMLAttributes x)) (listXMLNodes x)
withContent :: String -> [Node] -> Either String (Maybe Text)
withContent k = \case
@@ -191,14 +215,12 @@ withContent k = \case
[NodeContent x] -> Right (Just x)
_ -> Left $ "encountered many nodes, when expecting text: " ++ k
-withElement :: Text -> ([Node] -> Either String a) -> [Node] -> Either String a
-withElement n f = findElement n >=> f
-
-- | Find a specific named NodeElement, at the current depth in the node tree.
--
-- Fails if absent.
findElement :: Text -> [Node] -> Either String [Node]
-findElement n ns = missingElement n ns
+findElement n ns =
+ missingElement n ns
. listToMaybe
$ mapMaybe (childNodesOf n) ns
@@ -206,23 +228,35 @@ findElement n ns = missingElement n ns
--
-- Fails if absent.
firstElement :: Text -> [Node] -> Either String [Node]
-firstElement n ns = missingElement n ns
+firstElement n ns =
+ missingElement n ns
. listToMaybe
$ mapMaybe go ns
where
- go (NodeElement e)
- | n == nameLocalName (elementName e)
- = Just (elementNodes e)
- | otherwise = listToMaybe $ mapMaybe go (elementNodes e)
- go _ = Nothing
+ go x = case x of
+ NodeElement e
+ | Just n == localName x -> Just (childrenOf e)
+ | otherwise -> listToMaybe (mapMaybe go (elementNodes e))
+ _ -> Nothing
childNodesOf :: Text -> Node -> Maybe [Node]
childNodesOf n x = case x of
NodeElement e
| Just n == localName x
- -> Just (elementNodes e)
+ -> Just (childrenOf e)
_ -> Nothing
+childrenOf :: Element -> [Node]
+childrenOf e = elementNodes e <> map node (toList (elementAttributes e))
+ where
+ node (k, v) = NodeElement (Element (name k) mempty [NodeContent v])
+
+ name k = Name
+ { nameLocalName = fromMaybe "" (namePrefix k) <> ":" <> nameLocalName k
+ , nameNamespace = mempty
+ , namePrefix = mempty
+ }
+
localName :: Node -> Maybe Text
localName = \case
NodeElement e -> Just (nameLocalName (elementName e))
diff --git a/src/Network/AWS/Endpoint.hs b/src/Network/AWS/Endpoint.hs
index a9eba1d..3b724c8 100644
--- a/src/Network/AWS/Endpoint.hs
+++ b/src/Network/AWS/Endpoint.hs
@@ -5,9 +5,9 @@
-- |
-- Module : Network.AWS.Types
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Error.hs b/src/Network/AWS/Error.hs
index 0fff847..dae1701 100644
--- a/src/Network/AWS/Error.hs
+++ b/src/Network/AWS/Error.hs
@@ -4,30 +4,57 @@
-- |
-- Module : Network.AWS.Error
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
module Network.AWS.Error where
-import Control.Applicative
-import Control.Monad
-import Data.Aeson
-import Data.Aeson.Types (parseEither)
-import Data.Maybe
-import Data.Monoid
-import Network.AWS.Data.ByteString
-import Network.AWS.Data.Headers
-import Network.AWS.Data.Text
-import Network.AWS.Data.XML
-import Network.AWS.Lens (Choice, Getting, Optic', filtered)
-import Network.AWS.Types
-import Network.HTTP.Conduit
-import Network.HTTP.Types.Status (Status (..))
-
-import qualified Data.ByteString.Lazy as LBS
+import Control.Applicative
+import Control.Monad
+
+import Data.Aeson
+import Data.Aeson.Types (parseEither)
+import Data.Maybe
+import Data.Monoid
+
+import Network.AWS.Data.ByteString
+import Network.AWS.Data.Headers
+import Network.AWS.Data.Text
+import Network.AWS.Data.XML
+import Network.AWS.Lens (Choice, Getting, Optic', filtered)
+import Network.AWS.Types
+import Network.HTTP.Conduit
+import Network.HTTP.Types.Status (Status (..))
+
+import qualified Data.ByteString.Lazy as LBS
+
+-- | Provides a generalised prism for catching a specific service error
+-- identified by the opaque service abbreviation and error code.
+--
+-- This can be used if the generated error prisms provided by
+-- @Network.AWS.<ServiceName>.Types@ do not cover all the thrown error codes.
+-- For example to define a new error prism:
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- >
+-- > import Network.AWS.S3 (ServiceError, s3)
+-- >
+-- > _NoSuchBucketPolicy :: AsError a => Getting (First ServiceError) a ServiceError
+-- > _NoSuchBucketPolicy = _MatchServiceError s3 "NoSuchBucketPolicy"
+--
+-- With example usage being:
+--
+-- >>> import Control.Exception.Lens (trying)
+-- >>> :t trying _NoSuchBucketPolicy
+-- MonadCatch m => m a -> m (Either ServiceError a)
+_MatchServiceError :: AsError a
+ => Service
+ -> ErrorCode
+ -> Getting (First ServiceError) a ServiceError
+_MatchServiceError s c = _ServiceError . hasService s . hasCode c
statusSuccess :: Status -> Bool
statusSuccess (statusCode -> n) = n >= 200 && n < 300
@@ -50,6 +77,11 @@ httpStatus = _Error . f
-> (\x -> ServiceError (e { _serviceStatus = x }))
<$> g (_serviceStatus e)
+hasService :: (Applicative f, Choice p)
+ => Service
+ -> Optic' p f ServiceError ServiceError
+hasService s = filtered ((_svcAbbrev s ==) . _serviceAbbrev)
+
hasStatus :: (Applicative f, Choice p)
=> Int
-> Optic' p f ServiceError ServiceError
diff --git a/src/Network/AWS/Lens.hs b/src/Network/AWS/Lens.hs
index d918406..c06310d 100644
--- a/src/Network/AWS/Lens.hs
+++ b/src/Network/AWS/Lens.hs
@@ -1,8 +1,8 @@
-- |
-- Module : Network.AWS.Lens
--- Copyright : (c) 2013-2016 Brendan Hay <brendan.g.hay@gmail.com>
+-- Copyright : (c) 2013-2017 Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Pager.hs b/src/Network/AWS/Pager.hs
index e13d701..e6aec9f 100644
--- a/src/Network/AWS/Pager.hs
+++ b/src/Network/AWS/Pager.hs
@@ -3,9 +3,9 @@
-- |
-- Module : Network.AWS.Pager
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -19,6 +19,8 @@ module Network.AWS.Pager
import Control.Applicative
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe (isJust, fromMaybe)
import Data.Text (Text)
import Network.AWS.Data.Text (ToText (..))
import Network.AWS.Lens (Getter, to)
@@ -37,24 +39,18 @@ class AWSTruncated a where
instance AWSTruncated Bool where
truncated = id
-instance AWSTruncated (Maybe Int) where
- truncated (Just _) = True
- truncated Nothing = False
-
-instance AWSTruncated (Maybe Bool) where
- truncated (Just x) = x
- truncated Nothing = False
-
-instance AWSTruncated (Maybe Text) where
- truncated (Just _) = True
- truncated Nothing = False
-
instance AWSTruncated [a] where
truncated = not . null
instance AWSTruncated (HashMap k v) where
truncated = not . Map.null
+instance {-# OVERLAPPABLE #-} AWSTruncated (Maybe a) where
+ truncated = isJust
+
+instance {-# OVERLAPS #-} AWSTruncated (Maybe Bool) where
+ truncated = fromMaybe False
+
stop :: AWSTruncated a => a -> Bool
stop = not . truncated
diff --git a/src/Network/AWS/Prelude.hs b/src/Network/AWS/Prelude.hs
index 9f35f05..e77a0f7 100644
--- a/src/Network/AWS/Prelude.hs
+++ b/src/Network/AWS/Prelude.hs
@@ -1,8 +1,8 @@
-- |
-- Module : Network.AWS.Prelude
--- Copyright : (c) 2013-2016 Brendan Hay <brendan.g.hay@gmail.com>
+-- Copyright : (c) 2013-2017 Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -44,10 +44,9 @@ import Network.AWS.Data.Time as Export
import Network.AWS.Data.XML as Export
import Network.AWS.Endpoint as Export
import Network.AWS.Error as Export
-import Network.AWS.Types as Export hiding (AccessKey,
- Algorithm, Endpoint,
- LogLevel (..), Seconds,
- SecretKey, Signer,
+import Network.AWS.Types as Export hiding (Algorithm,
+ Endpoint, LogLevel (..),
+ Seconds, Signer,
serviceEndpoint)
infixl 7 .!@
diff --git a/src/Network/AWS/Request.hs b/src/Network/AWS/Request.hs
index 42f2ca9..9c57271 100644
--- a/src/Network/AWS/Request.hs
+++ b/src/Network/AWS/Request.hs
@@ -4,9 +4,9 @@
-- |
-- Module : Network.AWS.Request
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Response.hs b/src/Network/AWS/Response.hs
index 2767ca7..fd8e099 100644
--- a/src/Network/AWS/Response.hs
+++ b/src/Network/AWS/Response.hs
@@ -6,9 +6,9 @@
-- |
-- Module : Network.AWS.Response
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Sign/V2.hs b/src/Network/AWS/Sign/V2.hs
index 18ea627..4e21de2 100644
--- a/src/Network/AWS/Sign/V2.hs
+++ b/src/Network/AWS/Sign/V2.hs
@@ -6,9 +6,9 @@
-- |
-- Module : Network.AWS.Sign.V2
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Sign/V2Header.hs b/src/Network/AWS/Sign/V2Header.hs
new file mode 100644
index 0000000..21e33bc
--- /dev/null
+++ b/src/Network/AWS/Sign/V2Header.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- |
+-- Module : Network.AWS.Sign.V2Header
+-- Stability : experimental
+-- Portability : non-portable (GHC extensions)
+--
+-- This module provides an AWS compliant V2 Header request signer. It is based
+-- heavily on boto (https://github.com/boto/boto), specifically boto's
+-- @HmacAuthV1Handler@ AWS capable signer. AWS documentation is available
+-- <http://docs.aws.amazon.com/AmazonS3/latest/dev/RESTAuthentication.html here>.
+--
+-- /Notice/: Limitations include an inability to sign with a security token and
+-- inability to overwrite the @Date@ header with an expiry.
+module Network.AWS.Sign.V2Header
+ ( v2Header
+ ) where
+
+import Data.Monoid
+import Data.Time
+import Network.AWS.Data.Body
+import Network.AWS.Data.ByteString
+import Network.AWS.Data.Crypto
+import Network.AWS.Data.Headers
+import Network.AWS.Data.Log
+import Network.AWS.Data.Path
+import Network.AWS.Data.Time
+import qualified Network.AWS.Sign.V2Header.Base as V2
+import Network.AWS.Types
+import qualified Network.HTTP.Conduit as Client
+import Network.HTTP.Types
+
+data V2Header = V2Header
+ { metaTime :: !UTCTime
+ , metaEndpoint :: !Endpoint
+ , metaSignature :: !ByteString
+ , headers :: !Network.HTTP.Types.RequestHeaders
+ , signer :: !ByteString
+ }
+
+instance ToLog V2Header where
+ build V2Header{..} = buildLines
+ [ "[Version 2 Header Metadata] {"
+ , " time = " <> build metaTime
+ , " endpoint = " <> build (_endpointHost metaEndpoint)
+ , " signature = " <> build metaSignature
+ , " headers = " <> build headers
+ , " signer = " <> build signer
+ , "}"
+ ]
+
+v2Header :: Signer
+v2Header = Signer sign (const sign)
+
+sign :: Algorithm a
+sign Request{..} AuthEnv{..} r t = Signed meta rq
+ where
+ meta = Meta (V2Header t end signature headers signer)
+
+ signer = V2.newSigner headers meth path' _rqQuery
+
+ rq = (clientRequest end _svcTimeout)
+ { Client.method = meth
+ , Client.path = path'
+ , Client.queryString = toBS _rqQuery
+ , Client.requestHeaders = headers
+ , Client.requestBody = toRequestBody _rqBody
+ }
+
+ meth = toBS _rqMethod
+ path' = toBS (escapePath _rqPath)
+
+ end@Endpoint{..} = _svcEndpoint r
+
+ Service{..} = _rqService
+
+ signature = digestToBase Base64
+ . hmacSHA1 (toBS _authSecret) $ signer
+
+ headers =
+ hdr hDate time
+ . hdr hAuthorization ("AWS " <> toBS _authAccess <> ":" <> signature)
+ $ _rqHeaders
+
+ time = toBS (Time t :: RFC822)
diff --git a/src/Network/AWS/Sign/V2Header/Base.hs b/src/Network/AWS/Sign/V2Header/Base.hs
new file mode 100644
index 0000000..7513de7
--- /dev/null
+++ b/src/Network/AWS/Sign/V2Header/Base.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- |
+-- Module : Network.AWS.Sign.V2Header.Base
+-- Stability : experimental
+-- Portability : non-portable (GHC extensions)
+--
+-- This module provides auxiliary functions necessary for the AWS compliant V2
+-- Header request signer.
+-- /See/: "Network.AWS.Sign.V2Header"
+module Network.AWS.Sign.V2Header.Base
+ ( newSigner
+
+ -- * Testing
+ , toSignerQueryBS
+
+ , constructSigningHeader
+ , constructSigningQuery
+ , constructFullPath
+
+ , unionNecessaryHeaders
+ ) where
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as Build
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.CaseInsensitive as CI
+import Data.Function (on)
+import qualified Data.List as List
+import Data.Monoid (mempty, (<>))
+import qualified Network.AWS.Data.Query as Query
+import qualified Network.HTTP.Types as HTTP
+import Network.HTTP.Types.URI (urlEncode)
+
+-- | Construct a full header signer following the V2 Header scheme
+newSigner :: HTTP.RequestHeaders
+ -> ByteString
+ -> ByteString
+ -> Query.QueryString
+ -> ByteString
+newSigner headers method path query = signer
+ where
+ signer =
+ BS8.intercalate "\n"
+ ( method
+ : map constructSigningHeader (List.sort filteredHeaders)
+ ++ [constructFullPath path (toSignerQueryBS filteredQuery)]
+ )
+
+ filteredHeaders = unionNecessaryHeaders (filter isInterestingHeader headers)
+
+ filteredQuery = constructSigningQuery query
+
+-- | The following function mostly follows the toBS in amazonka QueryString
+-- except for single QValue or single QPair keys not being suffixed with
+-- an equals.
+toSignerQueryBS :: Query.QueryString -> ByteString
+toSignerQueryBS =
+ LBS.toStrict . Build.toLazyByteString . cat . List.sort . enc Nothing
+ where
+ enc :: Maybe ByteString -> Query.QueryString -> [ByteString]
+ enc p = \case
+ Query.QList xs -> concatMap (enc p) xs
+
+ Query.QPair (urlEncode True -> k) x
+ | Just n <- p -> enc (Just (n <> kdelim <> k)) x -- <prev>.key <recur>
+ | otherwise -> enc (Just k) x -- key <recur>
+
+ Query.QValue (Just (urlEncode True -> v))
+ | Just n <- p -> [n <> vsep <> v] -- key=value
+ | otherwise -> [v]
+
+ _ | Just n <- p -> [n]
+ | otherwise -> []
+
+ cat :: [ByteString] -> Builder
+ cat [] = mempty
+ cat [x] = Build.byteString x
+ cat (x:xs) = Build.byteString x <> ksep <> cat xs
+
+ kdelim = "."
+ ksep = "&"
+ vsep = "="
+
+hasAWSPrefix :: CI.CI ByteString -> Bool
+hasAWSPrefix = BS8.isPrefixOf "aws-" . CI.foldedCase
+
+-- | Filter for 'interesting' keys within a QueryString
+isInterestingQueryKey :: ByteString -> Bool
+isInterestingQueryKey = \case
+ "acl" -> True
+ "cors" -> True
+ "defaultObjectAcl" -> True
+ "location" -> True
+ "logging" -> True
+ "partNumber" -> True
+ "policy" -> True
+ "requestPayment" -> True
+ "torrent" -> True
+ "versioning" -> True
+ "versionId" -> True
+ "versions" -> True
+ "website" -> True
+ "uploads" -> True
+ "uploadId" -> True
+ "response-content-type" -> True
+ "response-content-language" -> True
+ "response-expires" -> True
+ "response-cache-control" -> True
+ "response-content-disposition" -> True
+ "response-content-encoding" -> True
+ "delete" -> True
+ "lifecycle" -> True
+ "tagging" -> True
+ "restore" -> True
+ "storageClass" -> True
+ "websiteConfig" -> True
+ "compose" -> True
+ _ -> False
+
+-- | Filter for 'interesting' header fields
+isInterestingHeader :: HTTP.Header -> Bool
+isInterestingHeader (name, _)
+ | name == HTTP.hDate = True
+ | name == HTTP.hContentMD5 = True
+ | name == HTTP.hContentType = True
+ | hasAWSPrefix name = True
+ | otherwise = False
+
+-- | Constructs a query string for signing
+constructSigningQuery :: Query.QueryString -> Query.QueryString
+constructSigningQuery = \case
+ Query.QValue {} -> Query.QValue Nothing
+ Query.QList qs -> Query.QList (map constructSigningQuery qs)
+ Query.QPair k v
+ | isInterestingQueryKey k -> Query.QPair k v
+ | otherwise -> Query.QValue Nothing
+
+-- | Construct a header string for signing
+constructSigningHeader :: HTTP.Header -> ByteString
+constructSigningHeader (name, value)
+ | hasAWSPrefix name = CI.foldedCase name <> ":" <> value
+ | otherwise = value
+
+constructFullPath :: ByteString -> ByteString -> ByteString
+constructFullPath path q
+ | BS8.null q = path
+ | otherwise = path <> "?" <> q
+
+unionNecessaryHeaders :: [HTTP.Header] -> [HTTP.Header]
+unionNecessaryHeaders =
+ flip (List.unionBy (on (==) fst))
+ [ (HTTP.hContentMD5, "")
+ , (HTTP.hContentType, "")
+ ]
diff --git a/src/Network/AWS/Sign/V4.hs b/src/Network/AWS/Sign/V4.hs
index f232634..5a6fb1c 100644
--- a/src/Network/AWS/Sign/V4.hs
+++ b/src/Network/AWS/Sign/V4.hs
@@ -11,9 +11,9 @@
-- |
-- Module : Network.AWS.Sign.V4
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
diff --git a/src/Network/AWS/Sign/V4/Base.hs b/src/Network/AWS/Sign/V4/Base.hs
index 98f8767..bff6db2 100644
--- a/src/Network/AWS/Sign/V4/Base.hs
+++ b/src/Network/AWS/Sign/V4/Base.hs
@@ -11,40 +11,42 @@
-- |
-- Module : Network.AWS.Sign.V4.Base
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
module Network.AWS.Sign.V4.Base where
import Control.Applicative
+
import Data.Bifunctor
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BS8
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Foldable as Fold
import Data.Function (on)
import Data.List (nubBy, sortBy)
-import Data.Maybe
import Data.Monoid
+
import GHC.TypeLits
+
import Network.AWS.Data.ByteString
import Network.AWS.Data.Crypto
import Network.AWS.Data.Headers
import Network.AWS.Data.Log
import Network.AWS.Data.Path
import Network.AWS.Data.Query
+import Network.AWS.Data.Sensitive (_Sensitive)
import Network.AWS.Data.Time
-import Network.AWS.Lens ((%~), (<>~))
+import Network.AWS.Lens ((%~), (<>~), (^.))
import Network.AWS.Request
import Network.AWS.Types
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Foldable as Fold
import qualified Network.HTTP.Conduit as Client
import qualified Network.HTTP.Types.Header as H
-import Prelude
-
default (ByteString)
data V4 = V4
@@ -173,7 +175,7 @@ signMetadata a r ts presign digest rq = V4
, metaCanonicalHeaders = chs
, metaSignedHeaders = shs
, metaStringToSign = sts
- , metaSignature = signature (_authSecret a) scope sts
+ , metaSignature = signature (_authSecret a ^. _Sensitive) scope sts
, metaHeaders = _rqHeaders rq
, metaTimeout = _svcTimeout svc
}
diff --git a/src/Network/AWS/Sign/V4/Chunked.hs b/src/Network/AWS/Sign/V4/Chunked.hs
index 9bfe9fe..fe55684 100644
--- a/src/Network/AWS/Sign/V4/Chunked.hs
+++ b/src/Network/AWS/Sign/V4/Chunked.hs
@@ -14,9 +14,9 @@
-- |
-- Module : Network.AWS.Sign.V4.Chunked
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -24,22 +24,28 @@ module Network.AWS.Sign.V4.Chunked
( chunked
) where
-import Control.Applicative
-import qualified Data.ByteString as BS
-import Data.ByteString.Builder
-import qualified Data.ByteString.Char8 as BS8
-import Data.Conduit
-import Data.Maybe
-import Data.Monoid
-import Network.AWS.Data.Body
-import Network.AWS.Data.ByteString
-import Network.AWS.Data.Crypto
-import Network.AWS.Data.Headers
-import Network.AWS.Data.Time
-import Network.AWS.Lens ((<>~))
-import Network.AWS.Sign.V4.Base hiding (algorithm)
-import Network.AWS.Types
-import Network.HTTP.Types.Header
+import Control.Applicative
+
+import Data.ByteString.Builder
+import Data.Conduit
+import Data.Maybe
+import Data.Monoid
+
+import Network.AWS.Data.Body
+import Network.AWS.Data.ByteString
+import Network.AWS.Data.Crypto
+import Network.AWS.Data.Headers
+import Network.AWS.Data.Sensitive (_Sensitive)
+import Network.AWS.Data.Time
+import Network.AWS.Lens ((<>~), (^.))
+import Network.AWS.Sign.V4.Base hiding (algorithm)
+import Network.AWS.Types
+import Network.HTTP.Types.Header
+
+import Numeric (showHex)
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
default (Builder, Integer)
@@ -73,7 +79,7 @@ chunked c rq a r ts = signRequest meta (toRequestBody body) auth
<> byteString crlf
chunkSignature prev x =
- signature (_authSecret a) scope (chunkStringToSign prev x)
+ signature (_authSecret a ^. _Sensitive) scope (chunkStringToSign prev x)
chunkStringToSign prev x = Tag $ BS8.intercalate "\n"
[ algorithm
@@ -104,7 +110,7 @@ metadataLength c =
where
chunkLength :: Integral a => a -> Integer
chunkLength (toInteger -> n) =
- _chunkedLength c
+ fromIntegral (length (showHex n ""))
+ headerLength
+ signatureLength
+ crlfLength
diff --git a/src/Network/AWS/Types.hs b/src/Network/AWS/Types.hs
index 667211e..fd67f7b 100644
--- a/src/Network/AWS/Types.hs
+++ b/src/Network/AWS/Types.hs
@@ -11,9 +11,9 @@
-- |
-- Module : Network.AWS.Types
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -25,10 +25,15 @@ module Network.AWS.Types
, SecretKey (..)
, SessionToken (..)
-- ** Environment
- , AuthEnv (..)
, Auth (..)
, withAuth
+ , AuthEnv (..)
+ , accessKeyId
+ , secretAccessKey
+ , sessionToken
+ , expiration
+
-- * Logging
, LogLevel (..)
, Logger
@@ -126,11 +131,12 @@ import Control.DeepSeq
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
-import Data.Aeson hiding (Error)
-import Data.ByteString.Builder (Builder)
+
+import Data.Aeson hiding (Error)
+import Data.ByteString.Builder (Builder)
import Data.Coerce
import Data.Conduit
-import Data.Data (Data, Typeable)
+import Data.Data (Data, Typeable)
import Data.Hashable
import Data.IORef
import Data.Maybe
@@ -138,25 +144,28 @@ import Data.Monoid
import Data.Proxy
import Data.String
import Data.Time
-import GHC.Generics (Generic)
+
+import GHC.Generics (Generic)
+
import Network.AWS.Data.Body
import Network.AWS.Data.ByteString
import Network.AWS.Data.JSON
import Network.AWS.Data.Log
import Network.AWS.Data.Path
import Network.AWS.Data.Query
+import Network.AWS.Data.Sensitive (Sensitive, _Sensitive)
import Network.AWS.Data.Text
+import Network.AWS.Data.Time (ISO8601, _Time)
import Network.AWS.Data.XML
-import Network.AWS.Lens (Iso', Lens', Prism', Setter')
-import Network.AWS.Lens (exception, iso, lens, prism, sets)
-import Network.HTTP.Conduit hiding (Proxy, Request, Response)
+import Network.AWS.Lens (Iso', Lens', Prism', Setter')
+import Network.AWS.Lens (exception, iso, lens, mapping, prism, sets,
+ view)
+import Network.HTTP.Conduit hiding (Proxy, Request, Response)
import Network.HTTP.Types.Header
import Network.HTTP.Types.Method
-import Network.HTTP.Types.Status (Status)
+import Network.HTTP.Types.Status (Status)
-import qualified Data.ByteString as BS
import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
import qualified Network.HTTP.Conduit as Client
-- | A convenience alias to avoid type ambiguity.
@@ -502,49 +511,134 @@ class AWSRequest a where
-> ClientResponse
-> m (Response a)
--- | Access key credential.
+-- | An access key ID.
+--
+-- For example: @AKIAIOSFODNN7EXAMPLE@
+--
+-- /See:/ <http://docs.aws.amazon.com/general/latest/gr/aws-sec-cred-types.html Understanding and Getting Your Security Credentials>.
newtype AccessKey = AccessKey ByteString
- deriving (Eq, Show, IsString, ToText, ToByteString, ToLog)
+ deriving
+ ( Eq
+ , Show
+ , Read
+ , Data
+ , Typeable
+ , IsString
+ , ToText
+ , FromText
+ , ToByteString
+ , ToLog
+ , FromXML
+ , ToXML
+ , ToQuery
+ , Hashable
+ , NFData
+ )
+
+instance ToJSON AccessKey where toJSON = toJSONText
+instance FromJSON AccessKey where parseJSON = parseJSONText "AccessKey"
--- | Secret key credential.
+-- | Secret access key credential.
+--
+-- For example: @wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKE@
+--
+-- /See:/ <http://docs.aws.amazon.com/general/latest/gr/aws-sec-cred-types.html Understanding and Getting Your Security Credentials>.
newtype SecretKey = SecretKey ByteString
- deriving (Eq, IsString, ToText, ToByteString)
+ deriving
+ ( Eq
+ , Data
+ , Typeable
+ , IsString
+ , ToText
+ , FromText
+ , ToByteString
+ , FromXML
+ , ToXML
+ , Hashable
+ , NFData
+ )
+
+instance ToJSON SecretKey where toJSON = toJSONText
+instance FromJSON SecretKey where parseJSON = parseJSONText "SecretKey"
-- | A session token used by STS to temporarily authorise access to
-- an AWS resource.
+--
+-- /See:/ <http://docs.aws.amazon.com/IAM/latest/UserGuide/id_credentials_temp.html Temporary Security Credentials>.
newtype SessionToken = SessionToken ByteString
- deriving (Eq, IsString, ToText, ToByteString)
+ deriving
+ ( Eq
+ , Data
+ , Typeable
+ , IsString
+ , ToText
+ , FromText
+ , ToByteString
+ , FromXML
+ , ToXML
+ , Hashable
+ , NFData
+ )
+
+instance ToJSON SessionToken where toJSON = toJSONText
+instance FromJSON SessionToken where parseJSON = parseJSONText "SessionToken"
--- | The authorisation environment.
+-- | The AuthN/AuthZ credential environment.
data AuthEnv = AuthEnv
{ _authAccess :: !AccessKey
- , _authSecret :: !SecretKey
- , _authToken :: Maybe SessionToken
- , _authExpiry :: Maybe UTCTime
- }
+ , _authSecret :: !(Sensitive SecretKey)
+ , _authToken :: Maybe (Sensitive SessionToken)
+ , _authExpiry :: Maybe ISO8601
+ } deriving (Eq, Show, Data, Typeable, Generic)
+
+instance NFData AuthEnv
instance ToLog AuthEnv where
build AuthEnv{..} = buildLines
[ "[Amazonka Auth] {"
- , " access key = ****" <> key _authAccess
- , " secret key = ****"
- , " security token = " <> build (const "****" <$> _authToken :: Maybe Builder)
- , " expiry = " <> build _authExpiry
+ , " access key id = " <> build _authAccess
+ , " secret access key = " <> build _authSecret
+ , " session token = " <> build _authToken
+ , " expiration = " <> build (fmap (view _Time) _authExpiry)
, "}"
]
- where
- -- An attempt to preserve sanity when debugging which keys
- -- have been loaded by the auth module.
- key (AccessKey k) = build . BS.reverse . BS.take 6 $ BS.reverse k
instance FromJSON AuthEnv where
parseJSON = withObject "AuthEnv" $ \o -> AuthEnv
- <$> f AccessKey (o .: "AccessKeyId")
- <*> f SecretKey (o .: "SecretAccessKey")
- <*> fmap (f SessionToken) (o .:? "Token")
+ <$> o .: "AccessKeyId"
+ <*> o .: "SecretAccessKey"
+ <*> o .:? "Token"
<*> o .:? "Expiration"
- where
- f g = fmap (g . Text.encodeUtf8)
+
+instance FromXML AuthEnv where
+ parseXML x = AuthEnv
+ <$> x .@ "AccessKeyId"
+ <*> x .@ "SecretAccessKey"
+ <*> x .@? "SessionToken"
+ <*> x .@? "Expiration"
+
+-- | The access key ID that identifies the temporary security credentials.
+accessKeyId :: Lens' AuthEnv AccessKey
+accessKeyId = lens _authAccess (\s a -> s{ _authAccess = a })
+
+-- | The secret access key that can be used to sign requests.
+secretAccessKey :: Lens' AuthEnv SecretKey
+secretAccessKey =
+ lens _authSecret (\s a -> s { _authSecret = a })
+ . _Sensitive
+
+-- | The token that users must pass to the service API to use the temporary
+-- credentials.
+sessionToken :: Lens' AuthEnv (Maybe SessionToken)
+sessionToken =
+ lens _authToken (\s a -> s { _authToken = a })
+ . mapping _Sensitive
+
+-- | The date on which the current credentials expire.
+expiration :: Lens' AuthEnv (Maybe UTCTime)
+expiration =
+ lens _authExpiry (\s a -> s { _authExpiry = a })
+ . mapping _Time
-- | An authorisation environment containing AWS credentials, and potentially
-- a reference which can be refreshed out-of-band as temporary credentials expire.
@@ -566,6 +660,7 @@ data Region
| Ohio -- ^ US East ('us-east-2').
| NorthCalifornia -- ^ US West ('us-west-1').
| Oregon -- ^ US West ('us-west-2').
+ | Montreal -- ^ Canada ('ca-central-1').
| Tokyo -- ^ Asia Pacific ('ap-northeast-1').
| Seoul -- ^ Asia Pacific ('ap-northeast-2').
| Mumbai -- ^ Asia Pacific ('ap-south-1').
@@ -573,11 +668,12 @@ data Region
| Sydney -- ^ Asia Pacific ('ap-southeast-2').
| SaoPaulo -- ^ South America ('sa-east-1').
| Ireland -- ^ EU ('eu-west-1').
+ | London -- ^ EU ('eu-west-2').
| Frankfurt -- ^ EU ('eu-central-1').
| GovCloud -- ^ US GovCloud ('us-gov-west-1').
| GovCloudFIPS -- ^ US GovCloud FIPS (S3 Only, 'fips-us-gov-west-1').
| Beijing -- ^ China ('cn-north-1').
- deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
+ deriving (Eq, Ord, Read, Enum, Bounded, Show, Data, Typeable, Generic)
instance Hashable Region
instance NFData Region
@@ -588,6 +684,7 @@ instance FromText Region where
"us-east-2" -> pure Ohio
"us-west-1" -> pure NorthCalifornia
"us-west-2" -> pure Oregon
+ "ca-central-1" -> pure Montreal
"ap-northeast-1" -> pure Tokyo
"ap-northeast-2" -> pure Seoul
"ap-south-1" -> pure Mumbai
@@ -595,6 +692,7 @@ instance FromText Region where
"ap-southeast-2" -> pure Sydney
"sa-east-1" -> pure SaoPaulo
"eu-west-1" -> pure Ireland
+ "eu-west-2" -> pure London
"eu-central-1" -> pure Frankfurt
"us-gov-west-1" -> pure GovCloud
"fips-us-gov-west-1" -> pure GovCloudFIPS
@@ -608,6 +706,7 @@ instance ToText Region where
Ohio -> "us-east-2"
NorthCalifornia -> "us-west-1"
Oregon -> "us-west-2"
+ Montreal -> "ca-central-1"
Tokyo -> "ap-northeast-1"
Seoul -> "ap-northeast-2"
Mumbai -> "ap-south-1"
@@ -615,6 +714,7 @@ instance ToText Region where
Sydney -> "ap-southeast-2"
SaoPaulo -> "sa-east-1"
Ireland -> "eu-west-1"
+ London -> "eu-west-2"
Frankfurt -> "eu-central-1"
GovCloud -> "us-gov-west-1"
GovCloudFIPS -> "fips-us-gov-west-1"
diff --git a/src/Network/AWS/Waiter.hs b/src/Network/AWS/Waiter.hs
index 67f55f8..c448df0 100644
--- a/src/Network/AWS/Waiter.hs
+++ b/src/Network/AWS/Waiter.hs
@@ -5,9 +5,9 @@
-- |
-- Module : Network.AWS.Waiter
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : This Source Code Form is subject to the terms of
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
@@ -24,21 +24,23 @@ module Network.AWS.Waiter
-- * Matchers
, matchAll
, matchAny
+ , matchNonEmpty
, matchError
, matchStatus
-- * Util
- , nonEmpty
+ , nonEmptyText
) where
import Control.Applicative
+import Control.Lens (Fold, allOf, anyOf, to, (^..),
+ (^?))
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import Network.AWS.Data.ByteString
import Network.AWS.Data.Log
import Network.AWS.Error
-import Network.AWS.Lens (Fold, allOf, anyOf, to, (^?))
import Network.AWS.Types
type Acceptor a = Request a -> Either Error (Response a) -> Maybe Accept
@@ -72,6 +74,9 @@ matchAll x a l = match (allOf l (== x)) a
matchAny :: Eq b => b -> Accept -> Fold (Rs a) b -> Acceptor a
matchAny x a l = match (anyOf l (== x)) a
+matchNonEmpty :: Bool -> Accept -> Fold (Rs a) b -> Acceptor a
+matchNonEmpty x a l = match (\rs -> null (rs ^.. l) == x) a
+
matchStatus :: Int -> Accept -> Acceptor a
matchStatus x a _ = \case
Right (s, _) | x == fromEnum s -> Just a
@@ -88,5 +93,5 @@ match f a _ = \case
Right (_, rs) | f rs -> Just a
_ -> Nothing
-nonEmpty :: Fold a Text -> Fold a Bool
-nonEmpty l = l . to Text.null
+nonEmptyText :: Fold a Text -> Fold a Bool
+nonEmptyText f = f . to Text.null
diff --git a/test/Main.hs b/test/Main.hs
index 359f3d3..5b1dd8c 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -2,22 +2,25 @@
-- |
-- Module : Main
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
module Main (main) where
-import qualified Test.AWS.Data.Base64 as Base64
-import qualified Test.AWS.Data.List as List
-import qualified Test.AWS.Data.Maybe as Maybe
-import qualified Test.AWS.Data.Numeric as Numeric
-import qualified Test.AWS.Data.Path as Path
-import qualified Test.AWS.Data.Time as Time
-import qualified Test.AWS.Error as Error
-import qualified Test.AWS.Sign.V4 as V4
+import qualified Test.AWS.Data.Base64 as Base64
+import qualified Test.AWS.Data.List as List
+import qualified Test.AWS.Data.Maybe as Maybe
+import qualified Test.AWS.Data.Numeric as Numeric
+import qualified Test.AWS.Data.Path as Path
+import qualified Test.AWS.Data.Query as Query
+import qualified Test.AWS.Data.Time as Time
+import qualified Test.AWS.Error as Error
+import qualified Test.AWS.Sign.V2Header.BaseSpec as V2Header
+import qualified Test.AWS.Sign.V4 as V4
+
import Test.Tasty
main :: IO ()
@@ -28,6 +31,7 @@ main = defaultMain $
, Time.tests
, Base64.tests
, Maybe.tests
+ , Query.tests
]
, testGroup "paths"
@@ -39,7 +43,8 @@ main = defaultMain $
]
, testGroup "signing"
- [ V4.tests
+ [ V2Header.tests
+ , V4.tests
]
, Error.tests
diff --git a/test/Test/AWS/Arbitrary.hs b/test/Test/AWS/Arbitrary.hs
index a4115e0..d74fa98 100644
--- a/test/Test/AWS/Arbitrary.hs
+++ b/test/Test/AWS/Arbitrary.hs
@@ -1,13 +1,14 @@
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module : Test.AWS.Arbitrary
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
@@ -28,19 +29,30 @@ import Test.QuickCheck.Gen as QC
import qualified Test.QuickCheck.Unicode as Unicode
import Test.Tasty.QuickCheck
+instance Show (Signed a) where
+ show = const "Signed { <Meta> <ClientRequest> }"
+
instance Arbitrary Service where
arbitrary = svc <$> arbitrary
where
- svc a = Service
- { _svcAbbrev = a
+ svc abbrev = Service
+ { _svcAbbrev = abbrev
, _svcSigner = v4
- , _svcPrefix = Text.encodeUtf8 . Text.toLower $ toText a
+ , _svcPrefix = Text.encodeUtf8 . Text.toLower $ toText abbrev
, _svcVersion = "2012-01-01"
- , _svcEndpoint = defaultEndpoint (svc a)
+ , _svcEndpoint = defaultEndpoint (svc abbrev)
, _svcTimeout = Nothing
, _svcCheck = const False
- , _svcError = error "_svcError not defined."
- , _svcRetry = error "_svcRetry not defined."
+ , _svcRetry = Exponential 1 2 3 (Just . Text.pack . show)
+ , _svcError = \status hdrs _ ->
+ ServiceError $ ServiceError'
+ { _serviceAbbrev = abbrev
+ , _serviceStatus = status
+ , _serviceHeaders = hdrs
+ , _serviceCode = ErrorCode "Arbitrary.Service"
+ , _serviceMessage = Nothing
+ , _serviceRequestId = Nothing
+ }
}
instance Arbitrary (Request ()) where
@@ -107,10 +119,16 @@ instance Arbitrary RawPath where
return $! rawPath (BS8.intercalate "/" xs)
instance Arbitrary QueryString where
- arbitrary = oneof
- [ QList <$> arbitrary
- , QPair <$> arbitrary <*> arbitrary
- , QValue <$> arbitrary
+ arbitrary = sized arbitraryQS
+
+-- | Used to limit the recursion depth.
+arbitraryQS :: Int -> Gen QueryString
+arbitraryQS = \case
+ 0 -> QPair <$> arbitrary <*> (QValue <$> arbitrary)
+ n -> oneof
+ [ QValue <$> arbitrary
+ , QPair <$> arbitrary <*> arbitraryQS (n - 1)
+ , QList <$> (take 4 <$> QC.listOf (arbitraryQS (n `div` 2)))
]
instance (Arbitrary a, FoldCase a) => Arbitrary (CI a) where
@@ -136,5 +154,23 @@ instance Arbitrary UTCTime where
++ [ u { utctDayTime = t } | t <- shrink dayTime ]
instance Arbitrary Day where
- arbitrary = ModifiedJulianDay <$> (2000 +) <$> arbitrary
+ arbitrary = ModifiedJulianDay . (2000 +) <$> arbitrary
shrink = fmap ModifiedJulianDay . shrink . toModifiedJulianDay
+
+instance Arbitrary (Time a) where
+ arbitrary = Time <$> arbitrary
+
+instance Arbitrary AccessKey where
+ arbitrary = AccessKey <$> arbitrary
+
+instance (Arbitrary a) => Arbitrary (Sensitive a) where
+ arbitrary = Sensitive <$> arbitrary
+
+instance Arbitrary SecretKey where
+ arbitrary = SecretKey . fromString <$> suchThat Unicode.string (not . null)
+
+instance Arbitrary SessionToken where
+ arbitrary = SessionToken <$> arbitrary
+
+instance Arbitrary AuthEnv where
+ arbitrary = AuthEnv <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
diff --git a/test/Test/AWS/Data/Base64.hs b/test/Test/AWS/Data/Base64.hs
index 36df4d9..f43184f 100644
--- a/test/Test/AWS/Data/Base64.hs
+++ b/test/Test/AWS/Data/Base64.hs
@@ -2,9 +2,9 @@
-- |
-- Module : Test.AWS.Data.Base64
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
diff --git a/test/Test/AWS/Data/List.hs b/test/Test/AWS/Data/List.hs
index 537159f..f9721ae 100644
--- a/test/Test/AWS/Data/List.hs
+++ b/test/Test/AWS/Data/List.hs
@@ -2,9 +2,9 @@
-- |
-- Module : Test.AWS.Data.List
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
diff --git a/test/Test/AWS/Data/Maybe.hs b/test/Test/AWS/Data/Maybe.hs
index 807f610..a7a8f16 100644
--- a/test/Test/AWS/Data/Maybe.hs
+++ b/test/Test/AWS/Data/Maybe.hs
@@ -2,9 +2,9 @@
-- |
-- Module : Test.AWS.Data.Maybe
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
diff --git a/test/Test/AWS/Data/Numeric.hs b/test/Test/AWS/Data/Numeric.hs
index e5f0764..d8ab1f5 100644
--- a/test/Test/AWS/Data/Numeric.hs
+++ b/test/Test/AWS/Data/Numeric.hs
@@ -3,9 +3,9 @@
-- |
-- Module : Test.AWS.Data.Numeric
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
diff --git a/test/Test/AWS/Data/Path.hs b/test/Test/AWS/Data/Path.hs
index ac1071c..86fc7ec 100644
--- a/test/Test/AWS/Data/Path.hs
+++ b/test/Test/AWS/Data/Path.hs
@@ -2,9 +2,9 @@
-- |
-- Module : Test.AWS.Data.Path
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
diff --git a/test/Test/AWS/Data/Query.hs b/test/Test/AWS/Data/Query.hs
new file mode 100644
index 0000000..78f6184
--- /dev/null
+++ b/test/Test/AWS/Data/Query.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module : Test.AWS.Query.List
+-- Copyright : (c) 2013-2017 Brendan Hay
+-- License : Mozilla Public License, v. 2.0.
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
+-- Stability : experimental
+-- Portability : non-portable (GHC extensions)
+--
+module Test.AWS.Data.Query (tests) where
+
+import Network.AWS.Prelude
+import Test.Tasty
+import Test.Tasty.HUnit (testCase, (@?=))
+
+tests :: TestTree
+tests = testGroup "query"
+ [ testGroup "fromString"
+ [ testCase "key" $
+ parseQueryString "foo" @?=
+ QList [ QPair "foo" (QValue Nothing)
+ ]
+
+ , testCase "key=" $
+ parseQueryString "foo=" @?=
+ QList [ QPair "foo" (QValue Nothing)
+ ]
+
+ , testCase "key=value" $
+ parseQueryString "foo=bar" @?=
+ QList [ QPair "foo" (QValue (Just "bar"))
+ ]
+
+ , testCase "key&.." $
+ parseQueryString "foo&bar&baz" @?=
+ QList [ QPair "foo" (QValue Nothing)
+ , QPair "bar" (QValue Nothing)
+ , QPair "baz" (QValue Nothing)
+ ]
+
+ , testCase "key=value&.." $
+ parseQueryString "foo=1&bar=2&baz&qux=3" @?=
+ QList [ QPair "foo" (QValue (Just "1"))
+ , QPair "bar" (QValue (Just "2"))
+ , QPair "baz" (QValue Nothing)
+ , QPair "qux" (QValue (Just "3"))
+ ]
+
+ ]
+ ]
diff --git a/test/Test/AWS/Data/Time.hs b/test/Test/AWS/Data/Time.hs
index 3653a02..022a15b 100644
--- a/test/Test/AWS/Data/Time.hs
+++ b/test/Test/AWS/Data/Time.hs
@@ -4,9 +4,9 @@
-- |
-- Module : Test.AWS.Data.Time
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
diff --git a/test/Test/AWS/Error.hs b/test/Test/AWS/Error.hs
index 159331e..c841a35 100644
--- a/test/Test/AWS/Error.hs
+++ b/test/Test/AWS/Error.hs
@@ -3,9 +3,9 @@
-- |
-- Module : Test.AWS.Error
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
@@ -21,7 +21,7 @@ import qualified Data.Text.Encoding as Text
import Network.AWS.Error
import Network.AWS.Prelude
import Test.AWS.Arbitrary ()
-import Test.QuickCheck.Property
+import Test.QuickCheck.Property ()
import Test.Tasty
import Test.Tasty.HUnit
diff --git a/test/Test/AWS/Sign/V2Header/BaseSpec.hs b/test/Test/AWS/Sign/V2Header/BaseSpec.hs
new file mode 100644
index 0000000..b58fbb3
--- /dev/null
+++ b/test/Test/AWS/Sign/V2Header/BaseSpec.hs
@@ -0,0 +1,278 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module : Test.AWS.Sign.V2Header.BaseSpec
+-- Stability : experimental
+-- Portability : non-portable (GHC extensions)
+--
+module Test.AWS.Sign.V2Header.BaseSpec (tests) where
+
+import Control.Applicative
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.CaseInsensitive as CI
+import qualified Data.List as List
+import Data.List.Ordered (subset)
+import Data.Maybe (isJust)
+import Data.Monoid ((<>))
+import qualified Data.Text as Text
+import qualified Network.AWS.Data.Query as Query
+import Network.AWS.Sign.V2Header.Base
+import qualified Network.HTTP.Types as HTTP
+import qualified Test.QuickCheck as QC
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase, (@?=))
+import Test.Tasty.QuickCheck (Gen, Property, testProperty)
+
+tests :: TestTree
+tests = testGroup "v2Header.BaseSpec"
+ [ testGroup "constructSigningQuery"
+
+ [ testProperty "should always convert set QValues to Nothing"
+ prop_QValueEmpty
+ , testCase "should keep an unset QValue" $
+ constructSigningQuery (Query.QValue (Nothing :: Maybe ByteString)) @?= (Query.QValue (Nothing :: Maybe ByteString))
+ , testProperty "should discard QPairs that are not interesting to AWS"
+ prop_UninterestingQPairs
+ , testProperty "should keep all QPairs that are interesting to AWS"
+ prop_InterestingQPairs
+ , testCase "should keep an empty QList" $
+ constructSigningQuery (Query.QList []) @?= Query.QList []
+ , testCase "should keep a list of Nothing QValues" $
+ constructSigningQuery (Query.QList [(Query.QValue Nothing)]) @?= (Query.QList [(Query.QValue Nothing)])
+ , testProperty "should discard the contents of an unintersting QList"
+ prop_UninterestingQLists
+ , testProperty "should not discard all QC.elements in interesting QLists"
+ prop_InterestingQLists
+ ]
+
+ , testGroup "constructSigningHeader"
+ [ testProperty "should convert random headers to their header value"
+ prop_RandomHeaders
+ , testProperty "should convert interesting headers to their header value"
+ prop_InterestingHeaders
+ , testProperty "should convert aws headers to a canonical string"
+ prop_InterestingAwsHeaders
+ ]
+
+ , testGroup "auxiliary headers functions"
+ [ testProperty "should sort and preserve headers"
+ prop_SortedHeaders
+ , testCase "should contain empty md5 and empty content type headers if not present" $
+ [(HTTP.hContentMD5, ""), (HTTP.hContentType, "")] `subset` (unionNecessaryHeaders []) @?= True
+ , testCase "should preserve a set md5 and contain an empty content type header if not present" $
+ [(HTTP.hContentMD5, "123"), (HTTP.hContentType, "")] `subset` (unionNecessaryHeaders [(HTTP.hContentMD5, "123")]) @?= True
+ , testCase "should preserve a set content type and preserve an empty md5 header if not present" $
+ [(HTTP.hContentType, "123"), (HTTP.hContentMD5, "")] `subset` (unionNecessaryHeaders [(HTTP.hContentType, "123")]) @?= True
+ , testCase "should preserve md5 and content type headers if set" $
+ [(HTTP.hContentType, "123"), (HTTP.hContentMD5, "456")] `subset` unionNecessaryHeaders [(HTTP.hContentType, "123"), (HTTP.hContentMD5, "456")] @?= True
+ ]
+
+ , testGroup "toSingerQBS"
+ [ testCase "should convert an empty query string" $
+ toSignerQueryBS (Query.QValue Nothing) @?= ""
+ , testCase "should convert an empty value of QPair to just the key" $
+ toSignerQueryBS (Query.QPair "key" (Query.QValue Nothing)) @?= "key"
+ , testCase "should convert an empty value of QPair followed by QValue to just the key and just the value" $
+ toSignerQueryBS (Query.QList [(Query.QPair "key" (Query.QValue Nothing)), (Query.QValue $
+ Just "key2")]) @?= "key&key2"
+ ]
+
+ , testGroup "constructFullPath"
+ [ testCase "should convert an empty queryString to just the path" $
+ constructFullPath "path" "" @?= "path"
+ , testCase "should convert an empty value of QPair and a path to just the path and the key" $
+ constructFullPath "path" (toSignerQueryBS (Query.QPair "key" (Query.QValue Nothing))) @?= "path?key"
+ ]
+
+ , testGroup "should construct canonical headers"
+ [ testCase "should construct a canonical header from a base string" $
+ newSigner [] "GET" "\\" "" @?= "GET\n\n\n\\"
+ ]
+
+ ]
+
+-- Properties for non-empty QValues
+
+prop_QValueEmpty :: Property
+prop_QValueEmpty =
+ QC.forAll uninterestingQValues $ \qv ->
+ constructSigningQuery qv ==
+ Query.QValue (Nothing :: Maybe ByteString)
+
+-- Generators / properties for uninteresting query pairs
+
+prop_UninterestingQPairs :: Property
+prop_UninterestingQPairs =
+ QC.forAll uninterestingQPairs $ \qpair ->
+ constructSigningQuery qpair == Query.QValue Nothing
+
+uninterestingQPairs :: Gen Query.QueryString
+uninterestingQPairs =
+ Query.toQuery <$> ((,) <$> nonEmptyText <*> uninterestingQValues)
+
+-- Generators / properties for interesting query pairs
+
+prop_InterestingQPairs :: Property
+prop_InterestingQPairs =
+ QC.forAll interestingQPairs $ \qpair ->
+ constructSigningQuery qpair /= Query.QValue Nothing
+
+interestingQueryKey :: Gen ByteString
+interestingQueryKey =
+ QC.elements
+ [ "acl"
+ , "cors"
+ , "defaultObjectAcl"
+ , "location"
+ , "logging"
+ , "partNumber"
+ , "policy"
+ , "requestPayment"
+ , "torrent"
+ , "versioning"
+ , "versionId"
+ , "versions"
+ , "website"
+ , "uploads"
+ , "uploadId"
+ , "response-content-type"
+ , "response-content-language"
+ , "response-expires"
+ , "response-cache-control"
+ , "response-content-disposition"
+ , "response-content-encoding"
+ , "delete"
+ , "lifecycle"
+ , "tagging"
+ , "restore"
+ , "storageClass"
+ , "websiteConfig"
+ , "compose"
+ ]
+
+interestingQPairs :: Gen Query.QueryString
+interestingQPairs =
+ Query.toQuery <$> ((,) <$> interestingQueryKey <*> uninterestingQValues)
+
+-- Generators / properties for query lists
+
+prop_UninterestingQLists :: Property
+prop_UninterestingQLists =
+ QC.forAll uninterestingQLists $
+ not . containsAnything . constructSigningQuery
+
+uninterestingQLists :: Gen Query.QueryString
+uninterestingQLists =
+ Query.toQueryList
+ <$> nonEmptyByteString
+ <*> QC.listOf
+ ( QC.frequency
+ [ (1, uninterestingQPairs)
+ , (1, uninterestingQValues)
+ , (1, uninterestingQLists)
+ ]
+ )
+
+containsAnything :: Query.QueryString -> Bool
+containsAnything = \case
+ Query.QValue v -> isJust v
+ Query.QPair {} -> True
+ Query.QList qs -> any containsAnything qs
+
+interestingQLists :: Gen Query.QueryString
+interestingQLists =
+ Query.toQueryList
+ <$> interestingQueryKey
+ <*> QC.listOf
+ ( QC.frequency
+ [ (1, interestingQLists)
+ , (1, uninterestingQPairs)
+ , (1, uninterestingQValues)
+ , (1, uninterestingQLists)
+ ]
+ )
+
+-- this property should probably be expanded to check that all qpairs actually contain interesting query keys AND that uninteresting
+-- query keys are actually preserved underneath an interesting one
+prop_InterestingQLists :: Property
+prop_InterestingQLists =
+ QC.forAll interestingQLists $
+ containsAnything . constructSigningQuery
+
+prop_RandomHeaders :: Property
+prop_RandomHeaders =
+ QC.forAll randomHeaderGenerator $ \hdr ->
+ constructSigningHeader hdr == snd hdr
+
+prop_InterestingHeaders :: Property
+prop_InterestingHeaders =
+ QC.forAll interestingHeaderGenerator $ \hdr ->
+ constructSigningHeader hdr == snd hdr
+
+prop_InterestingAwsHeaders :: Property
+prop_InterestingAwsHeaders =
+ QC.forAll interestingAwsHeaderGenerator $ \hdr ->
+ constructSigningHeader hdr ==
+ (CI.foldedCase (fst hdr) <> ":" <> snd hdr)
+
+-- Generator / Property for headers
+randomHeaderGenerator :: Gen HTTP.Header
+randomHeaderGenerator =
+ (,) <$> (CI.mk <$> nonEmptyByteString) <*> nonEmptyByteString
+
+interestingAwsHeaderName :: Gen HTTP.HeaderName
+interestingAwsHeaderName =
+ CI.mk <$> BS8.pack <$> fmap ("aws-" <>) nonEmptyString
+
+interestingHeaderName :: Gen HTTP.HeaderName
+interestingHeaderName =
+ QC.elements [HTTP.hContentMD5, HTTP.hContentType, HTTP.hDate]
+
+interestingHeaderGenerator :: Gen HTTP.Header
+interestingHeaderGenerator =
+ (,) <$> interestingHeaderName <*> nonEmptyByteString
+
+interestingAwsHeaderGenerator :: Gen HTTP.Header
+interestingAwsHeaderGenerator =
+ (,) <$> interestingAwsHeaderName <*> nonEmptyByteString
+
+-- Generators / Properties for auxiliary header functions
+
+prop_SortedHeaders :: Property
+prop_SortedHeaders =
+ QC.forAll allHeadersGenerator $ \allHeaders -> testHeaders allHeaders
+
+allHeadersGenerator :: Gen [HTTP.Header]
+allHeadersGenerator =
+ QC.listOf $ QC.frequency
+ [ (1, interestingHeaderGenerator)
+ , (1, interestingAwsHeaderGenerator)
+ ]
+
+allIncreasing :: [HTTP.Header] -> Bool
+allIncreasing xs =
+ and $ zipWith (<=) mapped $ drop 1 mapped
+ where
+ mapped = map fst xs
+
+testHeaders :: [HTTP.Header] -> Bool
+testHeaders headers =
+ length sortedHeaders == length sortedHeaders && allIncreasing sortedHeaders
+ where
+ sortedHeaders = List.sort headers
+
+-- Generators for Text / QueryValues
+
+nonEmptyByteString :: Gen ByteString
+nonEmptyByteString = BS8.pack <$> nonEmptyString
+
+uninterestingQValues :: Gen Query.QueryString
+uninterestingQValues = Query.toQuery <$> nonEmptyText
+
+nonEmptyText :: Gen Text.Text
+nonEmptyText = Text.pack <$> nonEmptyString
+
+nonEmptyString :: Gen String
+nonEmptyString = QC.listOf1 QC.arbitrary
diff --git a/test/Test/AWS/Sign/V4.hs b/test/Test/AWS/Sign/V4.hs
index 134edd9..55e13af 100644
--- a/test/Test/AWS/Sign/V4.hs
+++ b/test/Test/AWS/Sign/V4.hs
@@ -3,27 +3,17 @@
-- |
-- Module : Test.AWS.Sign.V$
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
module Test.AWS.Sign.V4 (tests) where
-import qualified Data.ByteString.Char8 as BS8
-import qualified Data.Foldable as Fold
-import Data.List (sort)
-import Data.Monoid
-import Data.String
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-import Network.AWS.Prelude
-import Network.AWS.Sign.V4
-import Test.AWS.Arbitrary ()
-import Test.QuickCheck.Property
-import Test.Tasty
-import Test.Tasty.QuickCheck
+import Test.Tasty (TestTree, testGroup)
+
+import qualified Test.AWS.Sign.V4.Chunked as Chunked
-- Write some V4 signing properties:
-- test canonical query
@@ -36,4 +26,9 @@ import Test.Tasty.QuickCheck
-- test empty query
tests :: TestTree
-tests = testGroup "v4" []
+tests =
+ testGroup "v4"
+ [ testGroup "chunked"
+ [ Chunked.tests
+ ]
+ ]
diff --git a/test/Test/AWS/Sign/V4/Chunked.hs b/test/Test/AWS/Sign/V4/Chunked.hs
new file mode 100644
index 0000000..c08ce79
--- /dev/null
+++ b/test/Test/AWS/Sign/V4/Chunked.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module : Test.AWS.Sign.V$
+-- Copyright : (c) 2013-2017 Brendan Hay
+-- License : Mozilla Public License, v. 2.0.
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
+-- Stability : experimental
+-- Portability : non-portable (GHC extensions)
+--
+module Test.AWS.Sign.V4.Chunked (tests) where
+
+import Prelude hiding (elem)
+
+import Data.List (sort)
+import Data.Monoid
+import Data.String
+
+import Network.AWS.Lens ((%~), (&), (.~))
+import Network.AWS.Prelude
+import Network.AWS.Sign.V4
+
+import Numeric (showHex)
+
+import Test.AWS.Arbitrary ()
+import Test.QuickCheck.Property ()
+import Test.Tasty
+import Test.Tasty.QuickCheck
+
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Conduit.List as Conduit
+import qualified Data.Foldable as Fold
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Network.HTTP.Conduit as Client
+import qualified Test.QuickCheck as QC
+
+tests :: TestTree
+tests = testGroup "headers"
+ [ testProperty "empty body" testEmptyBody
+ , testProperty "1 chunk body" testOneChunkBody
+ , testProperty "2 chunks body" testTwoChunksBody
+ ]
+
+testEmptyBody :: Property
+testEmptyBody =
+ QC.forAll (mkSigned []) $ \Signed{..} ->
+ let elem = (`Fold.elem` Client.requestHeaders sgRequest)
+ in elem ("Content-Encoding", "aws-chunked")
+ && elem ("X-Amz-Decoded-Content-Length", "0")
+ && elem ("Content-Length", "86")
+
+testOneChunkBody :: Property
+testOneChunkBody =
+ let n = 123
+ str = BS8.pack . show
+ inp = BS8.replicate n 'a'
+
+ in QC.forAll (mkSigned [inp]) $ \Signed{..} ->
+ let elem = (`Fold.elem` Client.requestHeaders sgRequest)
+ in elem ("Content-Encoding", "aws-chunked")
+ && elem ("X-Amz-Decoded-Content-Length", str n)
+ && elem ("Content-Length", str (87 + n + 86))
+
+testTwoChunksBody :: Property
+testTwoChunksBody =
+ let size = fromIntegral defaultChunkSize
+ sizeLen = length (showHex size "")
+ n = 123
+ str = BS8.pack . show
+ full = BS8.replicate size 'a' -- full-sized chunk
+ final = BS8.replicate n 'b' -- final non-empty chunk
+
+ in QC.forAll (mkSigned [full, final]) $ \Signed{..} ->
+ let elem = (`Fold.elem` Client.requestHeaders sgRequest)
+ in elem ("Content-Encoding", "aws-chunked")
+ && elem ("X-Amz-Decoded-Content-Length", str (size + n))
+ && elem ("Content-Length", str (sizeLen + 85 + size + 87 + n + 86))
+
+mkSigned :: [BS8.ByteString] -> Gen (Signed ())
+mkSigned bs = do
+ aReq <- arbitrary
+ aService <- arbitrary
+
+ let svc = aService
+ & serviceSigner .~ v4
+
+ req = aReq
+ & rqBody .~ Chunked (mkBody bs)
+ & rqService .~ svc
+
+ rqSign req <$> arbitrary <*> arbitrary <*> arbitrary
+
+mkBody :: [BS8.ByteString] -> ChunkedBody
+mkBody bs =
+ ChunkedBody defaultChunkSize
+ (fromIntegral . sum $ fmap BS8.length bs)
+ (Conduit.sourceList bs)
+
diff --git a/test/Test/AWS/Util.hs b/test/Test/AWS/Util.hs
index fdbbfdd..fa48eff 100644
--- a/test/Test/AWS/Util.hs
+++ b/test/Test/AWS/Util.hs
@@ -2,9 +2,9 @@
-- |
-- Module : Test.AWS.Util
--- Copyright : (c) 2013-2016 Brendan Hay
+-- Copyright : (c) 2013-2017 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
+-- Maintainer : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--