diff --git a/amazonka-core.cabal b/amazonka-core.cabal --- 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 -copyright: Copyright (c) 2013-2016 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 @@ -24,6 +24,7 @@ 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 @@ 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 @@ , 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.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 @@ , 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Compat/Time.hs b/src/Network/AWS/Compat/Time.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/Base64.hs b/src/Network/AWS/Data/Base64.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/Body.hs b/src/Network/AWS/Data/Body.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/ByteString.hs b/src/Network/AWS/Data/ByteString.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) diff --git a/src/Network/AWS/Data/Crypto.hs b/src/Network/AWS/Data/Crypto.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -18,6 +18,7 @@ , digestToBase -- * Algorithms + , hmacSHA1 , hmacSHA256 , hashSHA256 , hashMD5 @@ -49,6 +50,11 @@ 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/JSON.hs b/src/Network/AWS/Data/JSON.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/List1.hs b/src/Network/AWS/Data/List1.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/Log.hs b/src/Network/AWS/Data/Log.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/Map.hs b/src/Network/AWS/Data/Map.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -23,14 +23,14 @@ , 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/Path.hs b/src/Network/AWS/Data/Path.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/Query.hs b/src/Network/AWS/Data/Query.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -25,6 +25,7 @@ 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 @@ (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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -17,9 +18,13 @@ 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 @@ deriving ( Eq , Ord - , Read , IsString , Monoid , Data @@ -44,10 +48,11 @@ , 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Data/Time.hs b/src/Network/AWS/Data/Time.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -193,6 +193,9 @@ 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 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -17,24 +18,31 @@ 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 @@ Left _ -> Right Nothing Right xs -> parseXML xs -infixr 7 @= +infixr 7 @=, @@= (@=) :: ToXML a => Name -> a -> XML n @= x = @@ -54,8 +62,13 @@ 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 @@ -- 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 @@ 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 @@ [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,22 +228,34 @@ -- -- 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 diff --git a/src/Network/AWS/Endpoint.hs b/src/Network/AWS/Endpoint.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Error.hs b/src/Network/AWS/Error.hs --- a/src/Network/AWS/Error.hs +++ b/src/Network/AWS/Error.hs @@ -4,31 +4,58 @@ -- | -- 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 +-- Maintainer : Brendan Hay -- 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 Control.Applicative +import Control.Monad -import qualified Data.ByteString.Lazy as LBS +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..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 @@ -49,6 +76,11 @@ ServiceError e -> (\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 diff --git a/src/Network/AWS/Lens.hs b/src/Network/AWS/Lens.hs --- 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 +-- Copyright : (c) 2013-2017 Brendan Hay -- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Pager.hs b/src/Network/AWS/Pager.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -19,6 +19,8 @@ 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,23 +39,17 @@ 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 --- 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 +-- Copyright : (c) 2013-2017 Brendan Hay -- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -44,10 +44,9 @@ 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Response.hs b/src/Network/AWS/Response.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- diff --git a/src/Network/AWS/Sign/V2.hs b/src/Network/AWS/Sign/V2.hs --- 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 +-- Maintainer : Brendan Hay -- 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 --- /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 +-- . +-- +-- /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 --- /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 -- .key + | otherwise -> enc (Just k) x -- key + + 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 --- 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 +-- Maintainer : Brendan Hay -- 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 --- 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 +-- Maintainer : Brendan Hay -- 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 @@ , 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -24,23 +24,29 @@ ( 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) chunked :: ChunkedBody -> Algorithm a @@ -73,7 +79,7 @@ <> 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 @@ 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -25,10 +25,15 @@ , SecretKey (..) , SessionToken (..) -- ** Environment - , AuthEnv (..) , Auth (..) , withAuth + , AuthEnv (..) + , accessKeyId + , secretAccessKey + , sessionToken + , expiration + -- * Logging , LogLevel (..) , Logger @@ -126,11 +131,12 @@ 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.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,50 +511,135 @@ -> ClientResponse -> m (Response a) --- | Access key credential. +-- | An access key ID. +-- +-- For example: @AKIAIOSFODNN7EXAMPLE@ +-- +-- /See:/ . 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 + ) --- | Secret key credential. +instance ToJSON AccessKey where toJSON = toJSONText +instance FromJSON AccessKey where parseJSON = parseJSONText "AccessKey" + +-- | Secret access key credential. +-- +-- For example: @wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKE@ +-- +-- /See:/ . 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:/ . newtype SessionToken = SessionToken ByteString - deriving (Eq, IsString, ToText, ToByteString) + deriving + ( Eq + , Data + , Typeable + , IsString + , ToText + , FromText + , ToByteString + , FromXML + , ToXML + , Hashable + , NFData + ) --- | The authorisation environment. +instance ToJSON SessionToken where toJSON = toJSONText +instance FromJSON SessionToken where parseJSON = parseJSONText "SessionToken" + +-- | 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. data Auth @@ -566,6 +660,7 @@ | 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 @@ | 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 @@ "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 @@ "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 @@ 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 @@ 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- @@ -24,21 +24,23 @@ -- * 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 @@ 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 @@ 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 --- 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 +-- Maintainer : Brendan Hay -- 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 @@ , Time.tests , Base64.tests , Maybe.tests + , Query.tests ] , testGroup "paths" @@ -39,7 +43,8 @@ ] , testGroup "signing" - [ V4.tests + [ V2Header.tests + , V4.tests ] , Error.tests diff --git a/test/Test/AWS/Arbitrary.hs b/test/Test/AWS/Arbitrary.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -28,19 +29,30 @@ import qualified Test.QuickCheck.Unicode as Unicode import Test.Tasty.QuickCheck +instance Show (Signed a) where + show = const "Signed { }" + 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 @@ 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 @@ ++ [ 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/Test/AWS/Data/List.hs b/test/Test/AWS/Data/List.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/Test/AWS/Data/Maybe.hs b/test/Test/AWS/Data/Maybe.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/Test/AWS/Data/Numeric.hs b/test/Test/AWS/Data/Numeric.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/Test/AWS/Data/Path.hs b/test/Test/AWS/Data/Path.hs --- 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 +-- Maintainer : Brendan Hay -- 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 --- /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 +-- 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/Test/AWS/Error.hs b/test/Test/AWS/Error.hs --- 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 +-- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -21,7 +21,7 @@ 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 --- /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 --- a/test/Test/AWS/Sign/V4.hs +++ b/test/Test/AWS/Sign/V4.hs @@ -3,28 +3,18 @@ -- | -- 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 +-- Maintainer : Brendan Hay -- 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 -- test query @@ -36,4 +26,9 @@ -- 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 --- /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 +-- 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 --- 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 +-- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) --