diff --git a/amazonka-core.cabal b/amazonka-core.cabal --- a/amazonka-core.cabal +++ b/amazonka-core.cabal @@ -1,6 +1,6 @@ name: amazonka-core -version: 0.3.6 -synopsis: Core functionality and data types for Amazonka libraries. +version: 1.0.0 +synopsis: Core data types and functionality for Amazonka libraries. homepage: https://github.com/brendanhay/amazonka license: OtherLicense license-file: LICENSE @@ -13,15 +13,12 @@ cabal-version: >= 1.10 description: - Core functionality, serialisation primitives, and data types for + Core data types, functionality and serialisation primitives for Amazonka related Amazon Web Services SDKs. . The external interface of this library is stable with respect to the - downstream Amazonka libraries, only, and as such is probably not suitable + downstream Amazonka libraries, only, and as such is not suitable for use in non-Amazonka projects. - . - /Warning:/ This is an experimental preview release which is still under - heavy development and not intended for public consumption, caveat emptor! source-repository head type: git @@ -38,61 +35,51 @@ ghc-options: -Wall exposed-modules: - Network.AWS.Data + Network.AWS.Compat.Locale + , Network.AWS.Compat.Time + , Network.AWS.Data.Base64 + , Network.AWS.Data.Body + , Network.AWS.Data.ByteString + , Network.AWS.Data.Crypto + , Network.AWS.Data.Headers + , Network.AWS.Data.JSON + , Network.AWS.Data.List1 + , Network.AWS.Data.Log + , Network.AWS.Data.Map + , Network.AWS.Data.Numeric + , Network.AWS.Data.Path + , Network.AWS.Data.Query + , Network.AWS.Data.Sensitive + , Network.AWS.Data.Text + , Network.AWS.Data.Time + , Network.AWS.Data.XML + , Network.AWS.Endpoint , Network.AWS.Error - , Network.AWS.Pagination + , Network.AWS.Pager , Network.AWS.Prelude - , Network.AWS.Request.JSON - , Network.AWS.Request.Query - , Network.AWS.Request.RestJSON - , Network.AWS.Request.RestXML - , Network.AWS.Request.S3 + , Network.AWS.Request , Network.AWS.Response - , Network.AWS.Signing + , Network.AWS.Sign.V2 + , Network.AWS.Sign.V4 , Network.AWS.Types - , Network.AWS.Waiters - - other-modules: - Network.AWS.Compat.Internal.Locale - , Network.AWS.Compat.Internal.Time - , Network.AWS.Data.Internal.Base64 - , Network.AWS.Data.Internal.Body - , Network.AWS.Data.Internal.ByteString - , Network.AWS.Data.Internal.Header - , Network.AWS.Data.Internal.JSON - , Network.AWS.Data.Internal.List - , Network.AWS.Data.Internal.Map - , Network.AWS.Data.Internal.Numeric - , Network.AWS.Data.Internal.Path - , Network.AWS.Data.Internal.Query - , Network.AWS.Data.Internal.Sensitive - , Network.AWS.Data.Internal.Text - , Network.AWS.Data.Internal.Time - , Network.AWS.Data.Internal.URI - , Network.AWS.Data.Internal.XML - , Network.AWS.Request.Internal - , Network.AWS.Signing.Internal - , Network.AWS.Signing.Internal.V2 - , Network.AWS.Signing.Internal.V4 + , Network.AWS.Waiter build-depends: - aeson > 0.7.0.6 - , attoparsec >= 0.12 + aeson >= 0.8 + , attoparsec >= 0.11.3 , base >= 4.7 && < 5 - , base16-bytestring >= 0.1 - , base64-bytestring >= 1 , bifunctors >= 4.1 , bytestring >= 0.9 - , case-insensitive >= 1.2 && < 2 + , case-insensitive >= 1.2 , conduit >= 1.1 , conduit-extra >= 1.1 - , cryptohash >= 0.11 - , data-default-class >= 0.0.1 + , cryptonite >= 0.4 + , exceptions >= 0.6 , hashable >= 1.2 - , http-client >= 0.4.3 && < 0.5 + , http-client >= 0.4.9 , http-types >= 0.8 , lens >= 4.4 - , mmorph >= 1 && < 2 + , memory >= 0.6 , mtl >= 2.1.3.1 , resourcet >= 1.1 , scientific >= 0.3 @@ -102,8 +89,8 @@ , transformers >= 0.2 , transformers-compat >= 0.3 , unordered-containers >= 0.2.5 - , vector >= 0.10.9 , xml-conduit >= 1.2 + , xml-types >= 0.3.4 if !impl(ghc>=7.9) build-depends: @@ -123,22 +110,31 @@ hs-source-dirs: test main-is: Main.hs - ghc-options: -Wall -threaded -with-rtsopts=-N + ghc-options: -Wall -threaded other-modules: - Test.AWS.Data + Test.AWS.Arbitrary + , Test.AWS.Data.Base64 , Test.AWS.Data.List - , Test.AWS.Data.Map + , Test.AWS.Data.Maybe , Test.AWS.Data.Numeric , Test.AWS.Data.Time - , Test.AWS.TH - , Test.AWS.Types + , Test.AWS.Sign.V4 + , Test.AWS.Util build-depends: - amazonka-core - , aeson + aeson + , amazonka-core , base + , bytestring + , case-insensitive + , http-types + , lens , tasty , tasty-hunit + , tasty-quickcheck , template-haskell , text + , time + , QuickCheck + , quickcheck-unicode diff --git a/src/Network/AWS/Compat/Internal/Locale.hs b/src/Network/AWS/Compat/Internal/Locale.hs deleted file mode 100644 --- a/src/Network/AWS/Compat/Internal/Locale.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE CPP #-} - --- Module : Network.AWS.Data.Compat.Internal.Locale --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Compat.Internal.Locale - ( defaultTimeLocale - , iso8601DateFormat - ) where - -#if MIN_VERSION_time(1,5,0) -import Data.Time.Format (defaultTimeLocale, iso8601DateFormat) -#else -import System.Locale (defaultTimeLocale, iso8601DateFormat) -#endif diff --git a/src/Network/AWS/Compat/Internal/Time.hs b/src/Network/AWS/Compat/Internal/Time.hs deleted file mode 100644 --- a/src/Network/AWS/Compat/Internal/Time.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE CPP #-} - --- Module : Network.AWS.Compat.Internal.Time --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Compat.Internal.Time - ( parseTime - ) where - -#if MIN_VERSION_time(1,5,0) -import Data.Time.Format (ParseTime, TimeLocale, parseTimeM) - -parseTime :: ParseTime a => TimeLocale -> String -> String -> Maybe a -parseTime = parseTimeM True -#else -import Data.Time.Format (parseTime) -#endif diff --git a/src/Network/AWS/Compat/Locale.hs b/src/Network/AWS/Compat/Locale.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Compat/Locale.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Network.AWS.Compat.Locale +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Compat.Locale + ( defaultTimeLocale + , iso8601DateFormat + ) where + +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale, iso8601DateFormat) +#else +import System.Locale (defaultTimeLocale, iso8601DateFormat) +#endif diff --git a/src/Network/AWS/Compat/Time.hs b/src/Network/AWS/Compat/Time.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Compat/Time.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Network.AWS.Compat.Time +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Compat.Time + ( parseTime + ) where + +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (ParseTime, TimeLocale, parseTimeM) + +parseTime :: ParseTime a => TimeLocale -> String -> String -> Maybe a +parseTime = parseTimeM True +#else +import Data.Time.Format (parseTime) +#endif diff --git a/src/Network/AWS/Data.hs b/src/Network/AWS/Data.hs deleted file mode 100644 --- a/src/Network/AWS/Data.hs +++ /dev/null @@ -1,72 +0,0 @@ --- Module : Network.AWS.Data --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - --- | Serialisation classes and primitives for the various --- formats used to communicate with AWS. -module Network.AWS.Data - ( - -- * ByteString - module Network.AWS.Data.Internal.ByteString - , module Network.AWS.Data.Internal.Base64 - - -- * Text - , module Network.AWS.Data.Internal.Text - - -- * Numeric - , module Network.AWS.Data.Internal.Numeric - - -- * Time - , module Network.AWS.Data.Internal.Time - - -- * Sensitive - , module Network.AWS.Data.Internal.Sensitive - - -- * HTTP - -- ** Body - , module Network.AWS.Data.Internal.Body - - -- ** Headers - , module Network.AWS.Data.Internal.Header - - -- ** Path - , module Network.AWS.Data.Internal.Path - - -- ** Query - , module Network.AWS.Data.Internal.Query - - -- ** URI - , module Network.AWS.Data.Internal.URI - - -- * XML - , module Network.AWS.Data.Internal.XML - - -- * JSON - , module Network.AWS.Data.Internal.JSON - - -- * Collections - , module Network.AWS.Data.Internal.List - , module Network.AWS.Data.Internal.Map - ) where - -import Network.AWS.Data.Internal.Base64 -import Network.AWS.Data.Internal.Body -import Network.AWS.Data.Internal.ByteString -import Network.AWS.Data.Internal.Header -import Network.AWS.Data.Internal.JSON -import Network.AWS.Data.Internal.List -import Network.AWS.Data.Internal.Map -import Network.AWS.Data.Internal.Numeric -import Network.AWS.Data.Internal.Path -import Network.AWS.Data.Internal.Query -import Network.AWS.Data.Internal.Sensitive -import Network.AWS.Data.Internal.Text -import Network.AWS.Data.Internal.Time -import Network.AWS.Data.Internal.URI -import Network.AWS.Data.Internal.XML diff --git a/src/Network/AWS/Data/Base64.hs b/src/Network/AWS/Data/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Base64.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Network.AWS.Data.Base64 +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Base64 + ( Base64 (..) + , _Base64 + ) where + +import Control.Lens +import Data.Aeson.Types +import qualified Data.Attoparsec.Text as AText +import qualified Data.ByteArray.Encoding as BA +import Data.Data (Data, Typeable) +import qualified Data.Text.Encoding as Text +import GHC.Generics (Generic) +import Network.AWS.Data.ByteString +import Network.AWS.Data.JSON +import Network.AWS.Data.Query +import Network.AWS.Data.Text +import Network.AWS.Data.XML + +import Prelude + +-- | Base64 encoded binary data. +-- +-- Encoding\/decoding is automatically deferred to serialisation and deserialisation +-- respectively. +newtype Base64 = Base64 { unBase64 :: ByteString } + deriving (Eq, Read, Ord, Data, Typeable, Generic) + +_Base64 :: Iso' Base64 ByteString +_Base64 = iso unBase64 Base64 + +-- FIXME: probably a mistake to wrap a ByteString since +-- the underlying serialisers (JSON, XML) use Text internally. +instance FromText Base64 where + parser = AText.takeText >>= + either fail (return . Base64) + . BA.convertFromBase BA.Base64 + . Text.encodeUtf8 + +instance ToByteString Base64 where + toBS = BA.convertToBase BA.Base64 . unBase64 + +instance Show Base64 where show = show . toBS +instance ToText Base64 where toText = Text.decodeUtf8 . toBS +instance ToQuery Base64 where toQuery = toQuery . toBS +instance FromXML Base64 where parseXML = parseXMLText "Base64" +instance ToXML Base64 where toXML = toXMLText +instance FromJSON Base64 where parseJSON = parseJSONText "Base64" +instance ToJSON Base64 where toJSON = toJSONText diff --git a/src/Network/AWS/Data/Body.hs b/src/Network/AWS/Data/Body.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Body.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-- | +-- Module : Network.AWS.Data.Body +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Body where + +import Control.Monad.Trans.Resource +import Data.Aeson +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.Conduit +import Data.String +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.Encoding as LText +import Network.AWS.Data.ByteString +import Network.AWS.Data.Crypto +import Network.AWS.Data.Query (QueryString) +import Network.AWS.Data.XML (encodeXML) +import Network.HTTP.Client +import Text.XML (Element) + +import Prelude + +-- | A streaming, exception safe response body. +newtype RsBody = RsBody + { bodyResponse :: ResumableSource (ResourceT IO) ByteString + } + +instance Show RsBody where + show = const "RsBody { ResumableSource (ResourceT IO) ByteString }" + +-- | An opaque request body containing a 'SHA256' hash. +data RqBody = RqBody + { bodySHA256 :: Digest SHA256 + , bodyRequest :: RequestBody + } + +instance Show RqBody where + show b = "RqBody { RequestBody " + ++ BS8.unpack (digestToBase Base16 (bodySHA256 b)) ++ " }" + +instance IsString RqBody where + fromString = toBody . LBS8.pack + +bodyStream :: RqBody -> Bool +bodyStream x = + case bodyRequest x of + RequestBodyLBS {} -> False + RequestBodyBS {} -> False + RequestBodyBuilder {} -> False + RequestBodyStream {} -> True + RequestBodyStreamChunked {} -> True + +bodyCalculateMD5 :: RqBody -> Maybe (Digest MD5) +bodyCalculateMD5 x = + let md5 = Just . hashMD5 + in case bodyRequest x of + RequestBodyLBS lbs -> md5 (toBS lbs) + RequestBodyBS bs -> md5 bs + RequestBodyBuilder _ b -> md5 (toBS b) + _ -> Nothing + +-- | Anything that can be safely converted to a 'RqBody'. +class ToBody a where + -- | Convert a value to a request body. + toBody :: a -> RqBody + +instance ToBody RqBody where + toBody = id + +instance ToBody LBS.ByteString where + toBody x = RqBody (hashlazy x) (RequestBodyLBS x) + +instance ToBody ByteString where + toBody x = RqBody (hash x) (RequestBodyBS x) + +instance ToBody Text where + toBody = toBody . Text.encodeUtf8 + +instance ToBody LText.Text where + toBody = toBody . LText.encodeUtf8 + +instance ToBody Value where + toBody = toBody . encode + +instance ToBody Element where + toBody = toBody . encodeXML + +instance ToBody QueryString where + toBody = toBody . toBS diff --git a/src/Network/AWS/Data/ByteString.hs b/src/Network/AWS/Data/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/ByteString.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Network.AWS.Data.ByteString +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) + +-- +module Network.AWS.Data.ByteString + ( + -- * ByteString + ByteString + , LazyByteString + , ToByteString (..) + , showBS + , stripBS + ) where + +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Builder as Build +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Char +import qualified Data.Text.Encoding as Text +import Data.Time (UTCTime) +import Network.AWS.Data.Text +import Network.HTTP.Types +import Numeric +import Numeric.Natural + +import Prelude + +type LazyByteString = LBS.ByteString + +showBS :: ToByteString a => a -> String +showBS = BS8.unpack . toBS + +stripBS :: ByteString -> ByteString +stripBS = BS8.dropWhile isSpace . fst . BS8.spanEnd isSpace + +class ToByteString a where + toBS :: a -> ByteString + + default toBS :: ToText a => a -> ByteString + toBS = Text.encodeUtf8 . toText + +instance ToByteString ByteString where toBS = id +instance ToByteString Builder where toBS = toBS . Build.toLazyByteString +instance ToByteString LazyByteString where toBS = LBS.toStrict +instance ToByteString Text where toBS = Text.encodeUtf8 +instance ToByteString String where toBS = BS8.pack +instance ToByteString Int where toBS = toBS . Build.intDec +instance ToByteString Integer where toBS = toBS . Build.integerDec +instance ToByteString Natural where toBS = toBS . toInteger +instance ToByteString Double where toBS = toBS . ($ "") . showFFloat Nothing +instance ToByteString StdMethod where toBS = renderStdMethod +instance ToByteString UTCTime where toBS = BS8.pack . show + +instance ToByteString a => ToByteString (CI a) where + toBS = toBS . CI.original diff --git a/src/Network/AWS/Data/Crypto.hs b/src/Network/AWS/Data/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Crypto.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-- | +-- Module : Network.AWS.Data.Crypto +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Crypto + ( + -- * Conversion + digestToBS + , digestToBase + + -- * Algorithms + , hmacSHA256 + , hashSHA256 + , hashMD5 + + -- * Contexts + , hash + , hashlazy + , hashInit + , hashUpdate + , hashFinalize + + -- * Re-exported + , HMAC + , Digest + , HashAlgorithm + , SHA256 (..) + , MD5 (..) + , Base (..) + ) where + +import "cryptonite" Crypto.Hash +import "cryptonite" Crypto.MAC.HMAC +import Data.ByteArray +import Data.ByteArray.Encoding +import Data.ByteString (ByteString) + +digestToBS :: ByteArrayAccess a => a -> ByteString +digestToBS = convert + +digestToBase :: ByteArrayAccess a => Base -> a -> ByteString +digestToBase = convertToBase + +hmacSHA256 :: (ByteArrayAccess a, ByteArray b) => a -> b -> HMAC SHA256 +hmacSHA256 = hmac + +hashSHA256 :: ByteArrayAccess a => a -> Digest SHA256 +hashSHA256 = hashWith SHA256 + +hashMD5 :: ByteArrayAccess a => a -> Digest MD5 +hashMD5 = hashWith MD5 diff --git a/src/Network/AWS/Data/Headers.hs b/src/Network/AWS/Data/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Headers.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Network.AWS.Data.Headers +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Headers + ( module Network.AWS.Data.Headers + , HeaderName + , Header + ) where + +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.CaseInsensitive as CI +import Data.Monoid +import qualified Data.Text.Encoding as Text +import Network.AWS.Data.ByteString +import Network.AWS.Data.Text +import Network.HTTP.Types + +import Prelude + +infixl 7 .#, .#? + +(.#) :: FromText a => ResponseHeaders -> HeaderName -> Either String a +hs .# k = hs .#? k >>= note + where + note Nothing = Left (BS8.unpack $ "Unable to find header: " <> CI.original k) + note (Just x) = Right x + +(.#?) :: FromText a => ResponseHeaders -> HeaderName -> Either String (Maybe a) +hs .#? k = + maybe (Right Nothing) + (fmap Just . fromText . Text.decodeUtf8) + (k `lookup` hs) + +infixr 7 =# + +(=#) :: ToHeader a => HeaderName -> a -> [Header] +(=#) = toHeader + +hdr :: HeaderName -> ByteString -> [Header] -> [Header] +hdr k v hs = (k, v) : filter ((/= k) . fst) hs + +class ToHeaders a where + toHeaders :: a -> [Header] + toHeaders = const mempty + +class ToHeader a where + toHeader :: HeaderName -> a -> [Header] + + default toHeader :: ToText a => HeaderName -> a -> [Header] + toHeader k = toHeader k . toText + +instance ToHeader Text where + toHeader k v = [(k, Text.encodeUtf8 v)] + +instance ToHeader ByteString where + toHeader k v = [(k, v)] + +instance ToText a => ToHeader (Maybe a) where + toHeader k = maybe [] (toHeader k . toText) + +hHost :: HeaderName +hHost = "Host" + +hAMZToken :: HeaderName +hAMZToken = "X-Amz-Security-Token" + +hAMZTarget :: HeaderName +hAMZTarget = "X-Amz-Target" + +hAMZAlgorithm :: HeaderName +hAMZAlgorithm = "X-Amz-Algorithm" + +hAMZCredential :: HeaderName +hAMZCredential = "X-Amz-Credential" + +hAMZExpires :: HeaderName +hAMZExpires = "X-Amz-Expires" + +hAMZSignedHeaders :: HeaderName +hAMZSignedHeaders = "X-Amz-SignedHeaders" + +hAMZContentSHA256 :: HeaderName +hAMZContentSHA256 = "X-Amz-Content-SHA256" + +hAMZDate :: HeaderName +hAMZDate = "X-Amz-Date" + +hMetaPrefix :: HeaderName +hMetaPrefix = "X-Amz-" + +hAMZRequestId :: HeaderName +hAMZRequestId = "X-Amz-Request-Id" + +hAMZNRequestId :: HeaderName +hAMZNRequestId = "X-Amzn-RequestId" + +hAMZNErrorType :: HeaderName +hAMZNErrorType = "X-Amzn-ErrorType" + +hAMZNAuth :: HeaderName +hAMZNAuth = "X-Amzn-Authorization" diff --git a/src/Network/AWS/Data/Internal/Base64.hs b/src/Network/AWS/Data/Internal/Base64.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Base64.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- Module : Network.AWS.Data.Internal.Base64 --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Base64 - ( Base64 (..) - ) where - -import Data.Aeson.Types -import qualified Data.Attoparsec.Text as AText -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base64 as Base64 -import qualified Data.Text.Encoding as Text -import GHC.Generics -import Network.AWS.Data.Internal.ByteString -import Network.AWS.Data.Internal.JSON -import Network.AWS.Data.Internal.Query -import Network.AWS.Data.Internal.Text -import Network.AWS.Data.Internal.XML - --- | Base64 encoded binary data. --- --- Encoding/decoding is deferred to serialisation/deserialisation respectively. -newtype Base64 = Base64 { unBase64 :: ByteString } - deriving (Eq, Read, Ord, Generic) - -instance FromText Base64 where - parser = AText.takeText >>= - either fail (return . Base64) . Base64.decode . Text.encodeUtf8 - -instance Show Base64 where show = show . toBS -instance ToText Base64 where toText = Text.decodeUtf8 . toBS -instance ToByteString Base64 where toBS = Base64.encode . unBase64 -instance ToQuery Base64 where toQuery = toQuery . toText -instance FromXML Base64 where parseXML = parseXMLText "Base64" -instance ToXML Base64 where toXML = toXMLText -instance FromJSON Base64 where parseJSON = parseJSONText "Base64" -instance ToJSON Base64 where toJSON = toJSONText diff --git a/src/Network/AWS/Data/Internal/Body.hs b/src/Network/AWS/Data/Internal/Body.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Body.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- Module : Network.AWS.Data.Internal.Body --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Body where - -import Control.Lens -import Control.Monad.Morph -import Control.Monad.Trans.Resource -import Crypto.Hash -import Data.Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS8 -import Data.Conduit -import Data.List (intersperse) -import Data.Monoid -import Data.String -import Network.AWS.Data.Internal.ByteString -import Network.HTTP.Client - -data RsBody = RsBody (ResumableSource (ResourceT IO) ByteString) - -makePrisms ''RsBody - -instance ToBuilder RsBody where - build = const "RsBody { ResumableSource (ResourceT IO) ByteString }" - -instance Show RsBody where - show = LBS8.unpack . buildBS - -connectBody :: MonadResource m => RsBody -> Sink ByteString m a -> m a -connectBody (RsBody src) sink = hoist liftResourceT src $$+- sink - -data RqBody = RqBody - { _bdyHash :: Digest SHA256 - , _bdyBody :: RequestBody - } - -makeLenses ''RqBody - -bodyHash :: RqBody -> ByteString -bodyHash = digestToHexByteString . _bdyHash - -instance ToBuilder RqBody where - build x@(RqBody _ b) = mconcat $ intersperse "\n" - [ " Body {" - , " hash = " <> build (bodyHash x) - , " payload =\n" <> build b - , " }" - ] - -instance Show RqBody where - show = LBS8.unpack . buildBS . _bdyBody - -instance IsString RqBody where - fromString = toBody . LBS8.pack - -isStreaming :: RqBody -> Bool -isStreaming b = - case _bdyBody b of - RequestBodyLBS {} -> False - RequestBodyBS {} -> False - RequestBodyBuilder {} -> False - RequestBodyStream {} -> True - RequestBodyStreamChunked {} -> True - -class ToBody a where - toBody :: a -> RqBody - toBody = const (RqBody (hash "") (RequestBodyLBS mempty)) - -instance ToBody RqBody where - toBody = id - -instance ToBody LBS.ByteString where - toBody lbs = RqBody (hashlazy lbs) (RequestBodyLBS lbs) - -instance ToBody ByteString where - toBody = toBody . LBS.fromStrict - -instance ToBody Value where - toBody = toBody . encode diff --git a/src/Network/AWS/Data/Internal/ByteString.hs b/src/Network/AWS/Data/Internal/ByteString.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/ByteString.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.ByteString - ( LazyByteString - , ToByteString (..) - , ToBuilder (..) - , showBS - , buildBS - , stripBS - ) where - -import Crypto.Hash -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -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 Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Data.Char -import Data.Int -import Data.List (intersperse) -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -import Data.Time (UTCTime) -import Network.AWS.Data.Internal.Text -import Network.HTTP.Client -import Network.HTTP.Types -import Numeric.Natural - -type LazyByteString = LBS.ByteString - -showBS :: ToByteString a => a -> String -showBS = BS8.unpack . toBS - -class ToByteString a where - toBS :: a -> ByteString - - default toBS :: ToText a => a -> ByteString - toBS = Text.encodeUtf8 . toText - -instance ToByteString ByteString where toBS = id -instance ToByteString Builder where toBS = toBS . Build.toLazyByteString -instance ToByteString LazyByteString where toBS = LBS.toStrict -instance ToByteString Text where toBS = Text.encodeUtf8 -instance ToByteString Int where toBS = toBS . buildBS -instance ToByteString Integer where toBS = toBS . buildBS -instance ToByteString Natural where toBS = toBS . buildBS -instance ToByteString Double where toBS = toBS . buildBS -instance ToByteString StdMethod where toBS = renderStdMethod -instance ToByteString (Digest a) where toBS = digestToHexByteString -instance ToByteString UTCTime where toBS = BS8.pack . show - -instance ToByteString a => ToByteString (CI a) where - toBS = toBS . CI.original - -buildBS :: ToBuilder a => a -> LazyByteString -buildBS = Build.toLazyByteString . build - -class ToBuilder a where - build :: a -> Builder - - default build :: ToByteString a => a -> Builder - build = build . toBS - -instance ToBuilder Builder where build = id -instance ToBuilder ByteString where build = Build.byteString -instance ToBuilder LazyByteString where build = Build.lazyByteString -instance ToBuilder Text where build = Build.byteString . toBS -instance ToBuilder Char where build = Build.charUtf8 -instance ToBuilder [Char] where build = Build.stringUtf8 -instance ToBuilder Int where build = Build.intDec -instance ToBuilder Int64 where build = Build.int64Dec -instance ToBuilder Integer where build = Build.integerDec -instance ToBuilder Natural where build = Build.integerDec . toInteger -instance ToBuilder Double where build = Build.doubleDec -instance ToBuilder StdMethod -instance ToBuilder (Digest a) - -instance ToBuilder Bool where - build True = "True" - build False = "False" - -instance ToBuilder UTCTime where - build = Build.stringUtf8 . show - -instance ToBuilder a => ToBuilder (Maybe a) where - build Nothing = "Nothing" - build (Just x) = "Just " <> build x - -instance ToBuilder a => ToBuilder (CI a) where - build = build . CI.foldedCase - -instance ToBuilder [Header] where - build = mconcat - . intersperse "; " - . map (\(k, v) -> build k <> ": " <> build v) - -instance ToBuilder HttpVersion where - build HttpVersion{..} = "HTTP/" - <> build httpMajor - <> build '.' - <> build httpMinor - -instance ToBuilder RequestBody where - build = \case - RequestBodyLBS lbs - | n <= m -> build lbs - | otherwise -> " build n <> ">" - where - n = LBS.length lbs - - RequestBodyBS bs - | n <= fromIntegral m -> build bs - | otherwise -> " build n <> ">" - where - n = BS.length bs - - RequestBodyBuilder n _ -> " build n <> ">" - RequestBodyStream n _ -> " build n <> ">" - RequestBodyStreamChunked _ -> " " - where - m :: Int64 - m = 4096 - -instance ToBuilder Request where - build x = mconcat $ intersperse "\n" - [ "[Client Request] {" - , " host = " <> build (host x) - , " port = " <> build (port x) - , " secure = " <> build (secure x) - , " headers = " <> build (requestHeaders x) - , " path = " <> build (path x) - , " query = " <> build (queryString x) - , " method = " <> build (method x) - , " redirect count = " <> build (redirectCount x) - , " response timeout = " <> build (responseTimeout x) - , " request version = " <> build (requestVersion x) - , "}" - ] - -instance ToBuilder (Response a) where - build x = mconcat $ intersperse "\n" - [ "[Client Response] {" - , " status code = " <> build (statusCode s) - , " status message = " <> build (statusMessage s) - , " version = " <> build (responseVersion x) - , " headers = " <> build (responseHeaders x) - , " cookies = " <> build (show (responseCookieJar x)) - , "}" - ] - where - s = responseStatus x - -stripBS :: ByteString -> ByteString -stripBS = BS8.dropWhile isSpace . fst . BS8.spanEnd isSpace diff --git a/src/Network/AWS/Data/Internal/Header.hs b/src/Network/AWS/Data/Internal/Header.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Header.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} - --- Module : Network.AWS.Data.Internal.Header --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Header where - -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import Data.Foldable as Fold -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -import Network.AWS.Data.Internal.ByteString -import Network.AWS.Data.Internal.Text -import Network.HTTP.Types - -(~:) :: FromText a => ResponseHeaders -> HeaderName -> Either String a -hs ~: k = hs ~:? k >>= note - where - note Nothing = Left (BS.unpack $ "Unable to find header: " <> CI.original k) - note (Just x) = Right x - -(~:?) :: FromText a => ResponseHeaders -> HeaderName -> Either String (Maybe a) -hs ~:? k = - maybe (Right Nothing) - (fmap Just . fromText . Text.decodeUtf8) - (k `lookup` hs) - -class ToHeaders a where - toHeaders :: a -> [Header] - toHeaders = const mempty - -(=:) :: ToHeader a => HeaderName -> a -> [Header] -(=:) = toHeader - -hdr :: HeaderName -> ByteString -> [Header] -> [Header] -hdr k v hs = (k, v) : filter ((/= k) . fst) hs - -hdrs :: [Header] -> [Header] -> [Header] -hdrs xs ys = Fold.foldr' (uncurry hdr) ys xs - -toHeaderText :: ToText a => HeaderName -> a -> [Header] -toHeaderText k = toHeader k . toText - -class ToHeader a where - toHeader :: HeaderName -> a -> [Header] - - default toHeader :: ToText a => HeaderName -> a -> [Header] - toHeader k = toHeader k . toText - -instance ToHeader Text where - toHeader k = toHeader k . Text.encodeUtf8 - -instance ToHeader ByteString where - toHeader k = toHeader k . Just - -instance ToByteString a => ToHeader (Maybe a) where - toHeader k = maybe [] (\v -> [(k, toBS v)]) - -instance (ToByteString k, ToByteString v) => ToHeader (HashMap k v) where - toHeader p = map (\(k, v) -> (p <> CI.mk (toBS k), toBS v)) . Map.toList - -hHost :: HeaderName -hHost = "Host" - -hAMZToken :: HeaderName -hAMZToken = "X-Amz-Security-Token" - -hAMZTarget :: HeaderName -hAMZTarget = "X-Amz-Target" - -hAMZAlgorithm :: HeaderName -hAMZAlgorithm = "X-Amz-Algorithm" - -hAMZCredential :: HeaderName -hAMZCredential = "X-Amz-Credential" - -hAMZExpires :: HeaderName -hAMZExpires = "X-Amz-Expires" - -hAMZSignedHeaders :: HeaderName -hAMZSignedHeaders = "X-Amz-SignedHeaders" - -hAMZContentSHA256 :: HeaderName -hAMZContentSHA256 = "X-Amz-Content-SHA256" - -hAMZAuth :: HeaderName -hAMZAuth = "X-Amzn-Authorization" - -hAMZDate :: HeaderName -hAMZDate = "X-Amz-Date" - -hMetaPrefix :: HeaderName -hMetaPrefix = "X-Amz-" diff --git a/src/Network/AWS/Data/Internal/JSON.hs b/src/Network/AWS/Data/Internal/JSON.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/JSON.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Module : Network.AWS.Data.Internal.JSON --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.JSON - ( - -- * FromJSON - FromJSON (..) - , parseJSONText - , eitherDecode' - -- ** Parser a - , withObject - , (.:) - , (.:?) - , (.!=) - -- ** Either String a - , (.:>) - , (.:?>) - - -- * ToJSON - , ToJSON (..) - , toJSONText - , Object - , object - , (.=) - ) where - -import Data.Aeson (eitherDecode') -import Data.Aeson.Types -import qualified Data.HashMap.Strict as Map -import Data.Text (Text) -import Network.AWS.Data.Internal.Text - -parseJSONText :: FromText a => String -> Value -> Parser a -parseJSONText n = withText n (either fail return . fromText) - -toJSONText :: ToText a => a -> Value -toJSONText = String . toText - -(.:>) :: FromJSON a => Object -> Text -> Either String a -(.:>) o k = - case Map.lookup k o of - Nothing -> Left $ "key " ++ show k ++ " not present" - Just v -> parseEither parseJSON v - -(.:?>) :: FromJSON a => Object -> Text -> Either String (Maybe a) -(.:?>) o k = - case Map.lookup k o of - Nothing -> Right Nothing - Just v -> parseEither parseJSON v diff --git a/src/Network/AWS/Data/Internal/List.hs b/src/Network/AWS/Data/Internal/List.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/List.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - --- Module : Network.AWS.Data.Internal.List --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.List where - -import Control.Lens hiding (coerce, element) -import Control.Monad -import Data.Aeson -import Data.Coerce -import Data.Foldable (Foldable) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe -import Data.Monoid -import Data.Proxy -import Data.Semigroup (Semigroup) -import Data.String -import qualified Data.Text as Text -import qualified Data.Vector as Vector -import GHC.Exts -import GHC.TypeLits -import Network.AWS.Data.Internal.Query -import Network.AWS.Data.Internal.XML -import Text.XML - -newtype List (e :: Symbol) a = List { list :: [a] } - deriving (Eq, Ord, Read, Show, Semigroup, Monoid) - -newtype List1 (e :: Symbol) a = List1 { list1 :: NonEmpty a } - deriving (Eq, Ord, Read, Show, Semigroup) - -deriving instance Functor (List1 e) -deriving instance Foldable (List1 e) -deriving instance Traversable (List1 e) - -type role List phantom representational -type role List1 phantom representational - -_List :: (Coercible a b, Coercible b a) => Iso' (List e a) [b] -_List = iso (coerce . list) (List . coerce) - -_List1 :: (Coercible a b, Coercible b a) => Iso' (List1 e a) (NonEmpty b) -_List1 = iso (coerce . list1) (List1 . coerce) - -instance IsList (List e a) where - type Item (List e a) = a - - fromList = List - toList = list - -fromList1 :: List1 e a -> List e a -fromList1 = List . toList . list1 - -toList1 :: List e a -> Either String (List1 e a) -toList1 (List (x:xs)) - = Right $ List1 (x :| xs) -toList1 _ = Left $ "Unexpected empty list, expected at least 1 element." - -instance (KnownSymbol e, ToQuery a) => ToQuery (List e a) where - toQuery = toQueryList n . toList . list - where - n = fromString $ symbolVal (Proxy :: Proxy e) - -instance (KnownSymbol e, ToQuery a) => ToQuery (List1 e a) where - toQuery = toQueryList n . toList . list1 - where - n = fromString $ symbolVal (Proxy :: Proxy e) - -instance FromJSON a => FromJSON (List e a) where - parseJSON = fmap List . parseJSON - -instance FromJSON a => FromJSON (List1 e a) where - parseJSON = withArray "List1" $ \case - v | Vector.null v -> fail "Empty array, expected at least 1 element." - v -> traverse parseJSON - . List1 $ Vector.unsafeHead v :| Vector.toList (Vector.unsafeTail v) - -instance ToJSON a => ToJSON (List e a) where - toJSON = toJSON . list - -instance ToJSON a => ToJSON (List1 e a) where - toJSON = toJSON . toList . list1 - -instance (KnownSymbol e, FromXML a) => FromXML (List e a) where - parseXML = fmap List . traverse parseXML . mapMaybe (childNodes n) - where - n = Text.pack $ symbolVal (Proxy :: Proxy e) - -instance (KnownSymbol e, FromXML a) => FromXML (List1 e a) where - parseXML = parseXML >=> toList1 - -instance (KnownSymbol e, ToXML a) => ToXML (List e a) where - toXML = map (NodeElement . element n . toXML) . list - where - n = fromString $ symbolVal (Proxy :: Proxy e) - -instance (KnownSymbol e, ToXML a) => ToXML (List1 e a) where - toXML = toXML . fromList1 diff --git a/src/Network/AWS/Data/Internal/Map.hs b/src/Network/AWS/Data/Internal/Map.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Map.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- Module : Network.AWS.Data.Internal.Map --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Map - ( Map (..) - , _Map - , (~::) - - , EMap (..) - , _EMap - ) where - -import Control.Applicative -import Control.Lens hiding (coerce, element) -import Data.Aeson -import Data.Bifunctor -import qualified Data.ByteString.Char8 as BS -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Data.Coerce -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map -import Data.Hashable (Hashable) -import Data.Maybe -import Data.Monoid -import Data.Proxy -import Data.Semigroup (Semigroup) -import Data.String -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import GHC.Exts -import GHC.TypeLits -import Network.AWS.Data.Internal.ByteString -import Network.AWS.Data.Internal.Header -import Network.AWS.Data.Internal.Query -import Network.AWS.Data.Internal.Text -import Network.AWS.Data.Internal.XML -import Network.HTTP.Types.Header -import Text.XML - -newtype Map k v = Map - { fromMap :: HashMap k v - } deriving (Eq, Read, Show, Monoid, Semigroup) - -type role Map nominal representational - -_Map :: (Coercible a b, Coercible b a) => Iso' (Map k a) (HashMap k b) -_Map = iso (coerce . fromMap) (Map . coerce) - -instance (Eq k, Hashable k) => IsList (Map k v) where - type Item (Map k v) = (k, v) - - fromList = Map . Map.fromList - toList = Map.toList . fromMap - -instance (Eq k, Hashable k, FromText k, FromJSON v) => FromJSON (Map k v) where - parseJSON = withObject "HashMap" $ - fmap (Map . Map.fromList) - . traverse g - . Map.toList - where - g (k, v) = (,) - <$> either fail return (fromText k) - <*> parseJSON v - -instance (Eq k, Hashable k, ToText k, ToJSON v) => ToJSON (Map k v) where - toJSON = Object . Map.fromList . map (bimap toText toJSON) . toList - -(~::) :: ResponseHeaders - -> CI Text - -> Either String (Map (CI Text) Text) -hs ~:: (CI.foldedCase -> p) = Right . fromList $ mapMaybe f hs - where - f (CI.map Text.decodeUtf8 -> k, Text.decodeUtf8 -> v) = - (,v) . CI.mk <$> Text.stripPrefix p (CI.foldedCase k) - -instance ToHeader (Map (CI Text) Text) where - toHeader (CI.foldedCase -> p) = map (first CI.mk . f) . toList - where - f (CI.foldedCase -> toBS -> k, toBS -> v) - | BS.isPrefixOf p k = (k, v) - | otherwise = (p <> k, v) - -newtype EMap (e :: Symbol) (i :: Symbol) (j :: Symbol) k v = EMap - { fromEMap :: HashMap k v - } deriving (Eq, Read, Show, Monoid, Semigroup) - -type role EMap phantom phantom phantom nominal representational - -_EMap :: (Coercible a b, Coercible b a) => Iso' (EMap e i j k a) (HashMap k b) -_EMap = iso (coerce . fromEMap) (EMap . coerce) - -instance (Eq k, Hashable k) => IsList (EMap e i j k v) where - type Item (EMap e i j k v) = (k, v) - - fromList = EMap . Map.fromList - toList = Map.toList . fromEMap - -instance ( KnownSymbol e - , KnownSymbol i - , KnownSymbol j - , Eq k - , Hashable k - , ToQuery k - , ToQuery v - ) => ToQuery (EMap e i j k v) where - toQuery m = e =? (mconcat . zipWith go idx $ toList m) - where - go n (k, v) = toBS n =? toQuery (i, k) <> toQuery (j, v) - - idx = [1..] :: [Integer] - - i = BS.pack $ symbolVal (Proxy :: Proxy i) - j = BS.pack $ symbolVal (Proxy :: Proxy j) - e = BS.pack $ symbolVal (Proxy :: Proxy e) - -instance ( KnownSymbol e - , KnownSymbol i - , KnownSymbol j - , Eq k - , Hashable k - , FromXML k - , FromXML v - ) => FromXML (EMap e i j k v) where - parseXML = fmap fromList . traverse go . mapMaybe (childNodes e) - where - go ns = (,) - <$> withElement i parseXML ns - <*> withElement j parseXML ns - - i = fromString $ symbolVal (Proxy :: Proxy i) - j = fromString $ symbolVal (Proxy :: Proxy j) - e = fromString $ symbolVal (Proxy :: Proxy e) - -instance ( KnownSymbol e - , KnownSymbol i - , KnownSymbol j - , Eq k - , Hashable k - , ToXML k - , ToXML v - ) => ToXML (EMap e i j k v) where - toXML = map (uncurry go) . toList - where - go k v = - NodeElement $ element e - [ NodeElement (element i (toXML k)) - , NodeElement (element j (toXML v)) - ] - - i = fromString $ symbolVal (Proxy :: Proxy i) - j = fromString $ symbolVal (Proxy :: Proxy j) - e = fromString $ symbolVal (Proxy :: Proxy e) diff --git a/src/Network/AWS/Data/Internal/Numeric.hs b/src/Network/AWS/Data/Internal/Numeric.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Numeric.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - --- Module : Network.AWS.Data.Internal.Numeric --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Numeric where - -import Control.Lens.TH -import Control.Monad -import Data.Aeson.Types -import Data.Monoid -import Data.Scientific -import Network.AWS.Data.Internal.ByteString -import Network.AWS.Data.Internal.Query -import Network.AWS.Data.Internal.Text -import Network.AWS.Data.Internal.XML -import Numeric.Natural - -newtype Nat = Nat { unNat :: Natural } - deriving - ( Eq - , Ord - , Read - , Show - , Enum - , Num - , Real - , Integral - , ToByteString - , FromText - , ToText - , FromXML - , ToXML - , ToQuery - ) - -instance FromJSON Nat where - parseJSON = parseJSON >=> go - where - go n = case floatingOrInteger n of - Left (_ :: Double) -> fail (floatErr n) - Right i - | n < 0 -> fail (negateErr n) - | otherwise -> return . Nat $ fromInteger i - - floatErr = mappend "Cannot convert float to Natural: " . show - negateErr = mappend "Cannot convert negative number to Natural: " . show - -instance ToJSON Nat where - toJSON = Number . flip scientific 0 . toInteger . unNat - -makePrisms ''Nat diff --git a/src/Network/AWS/Data/Internal/Path.hs b/src/Network/AWS/Data/Internal/Path.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Path.hs +++ /dev/null @@ -1,23 +0,0 @@ --- Module : Network.AWS.Data.Internal.Path --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Path - ( ToPath (..) - ) where - -import Data.Monoid -import Data.Text (Text) - -class ToPath a where - toPath :: a -> Text - toPath = const mempty - -instance ToPath Text where - toPath = id diff --git a/src/Network/AWS/Data/Internal/Query.hs b/src/Network/AWS/Data/Internal/Query.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Query.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - --- Module : Network.AWS.Data.Internal.Query --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Query - ( ToQuery (..) - , renderQuery - - , Query - , valuesOf - - , (=?) - , pair - , toQueryList - ) where - -import Control.Lens -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Data.Data -import Data.Data.Lens -import Data.List (sort) -import Data.Monoid -import Data.String -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -import GHC.Exts -import Network.AWS.Data.Internal.ByteString -import Network.AWS.Data.Internal.Text -import Network.HTTP.Types.URI (urlEncode) -import Numeric.Natural - -data Query - = List [Query] - | Pair ByteString Query - | Value (Maybe ByteString) - deriving (Eq, Show, Data, Typeable) - -makePrisms ''Query - -instance Monoid Query where - mempty = List [] - - mappend a b = case (a, b) of - (List l, List r) -> List (l ++ r) - (List l, r) -> List (r : l) - (l, List r) -> List (l : r) - (l, r) -> List [l, r] - -instance Plated Query where - plate = uniplate - -instance ToByteString Query where - toBS = renderQuery - -instance ToBuilder Query - -instance ToText Query where - toText = Text.decodeUtf8 . toBS - -instance IsString Query where - fromString = toQuery . BS.pack - -valuesOf :: Traversal' Query (Maybe ByteString) -valuesOf = deep _Value - -pair :: ToQuery a => ByteString -> a -> Query -> Query -pair k v = mappend (Pair k (toQuery v)) - -(=?) :: ToQuery a => ByteString -> a -> Query -(=?) k v = Pair k (toQuery v) - -toQueryList :: (IsList a, ToQuery (Item a)) => ByteString -> a -> Query -toQueryList n = mconcat . zipWith (\i v -> n =? (toBS i, v)) idx . toList - where - idx = [1..] :: [Int] - -renderQuery :: Query -> ByteString -renderQuery = intercalate . sort . enc Nothing - where - enc k (List xs) = concatMap (enc k) xs - enc k (Pair (urlEncode True -> k') x) - | Just n <- k = enc (Just $ n <> "." <> k') x - | otherwise = enc (Just k') x - enc k (Value (Just (urlEncode True -> v))) - | Just n <- k = [n <> vsep <> v] - | otherwise = [v <> vsep] - enc k _ - | Just n <- k = [n <> vsep] - | otherwise = [] - - intercalate [] = mempty - intercalate [x] = x - intercalate (x:xs) = x <> ksep <> intercalate xs - - ksep = "&" - vsep = "=" - -class ToQuery a where - toQuery :: a -> Query - - default toQuery :: ToText a => a -> Query - toQuery = toQuery . toText - -instance ToQuery Query where - toQuery = id - -instance (ToByteString k, ToQuery v) => ToQuery (k, v) where - toQuery (k, v) = Pair (toBS k) (toQuery v) - -instance ToQuery Char where - toQuery = toQuery . BS.singleton - -instance ToQuery ByteString where - toQuery "" = Value Nothing - toQuery bs = Value (Just bs) - -instance ToQuery Text where toQuery = toQuery . Text.encodeUtf8 -instance ToQuery Int where toQuery = toQuery . toBS -instance ToQuery Integer where toQuery = toQuery . toBS -instance ToQuery Double where toQuery = toQuery . toBS -instance ToQuery Natural where toQuery = toQuery . toBS - -instance ToQuery a => ToQuery (Maybe a) where - toQuery (Just x) = toQuery x - toQuery Nothing = mempty - -instance ToQuery a => ToQuery [a] where - toQuery = List . zipWith (\n v -> toBS n =? toQuery v) idx - where - idx = [1..] :: [Integer] - -instance ToQuery Bool where - toQuery True = toQuery ("true" :: ByteString) - toQuery False = toQuery ("false" :: ByteString) diff --git a/src/Network/AWS/Data/Internal/Sensitive.hs b/src/Network/AWS/Data/Internal/Sensitive.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Sensitive.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- Module : Network.AWS.Data.Internal.Sensitive --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Sensitive where - -import Control.Lens -import Data.Monoid -import Data.String -import Network.AWS.Data.Internal.ByteString -import Network.AWS.Data.Internal.JSON -import Network.AWS.Data.Internal.Query -import Network.AWS.Data.Internal.Text -import Network.AWS.Data.Internal.XML - --- | read . show /= isomorphic -newtype Sensitive a = Sensitive { desensitise :: a } - deriving - ( Eq - , Ord - , Read - , IsString - , Monoid - , ToByteString - , FromText - , ToText - , FromXML - , ToXML - , ToQuery - , ToJSON - , FromJSON - ) - -instance Show (Sensitive a) where - show = const "******" - -_Sensitive :: Iso' (Sensitive a) a -_Sensitive = iso desensitise Sensitive diff --git a/src/Network/AWS/Data/Internal/Text.hs b/src/Network/AWS/Data/Internal/Text.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Text.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} - --- Module : Network.AWS.Data.Internal.Text --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Text - ( FromText (..) - , fromText - , takeLowerText - , matchCI - - , ToText (..) - , showText - ) where - -import Control.Applicative -import Crypto.Hash -import Data.Attoparsec.Text (Parser) -import qualified Data.Attoparsec.Text as AText -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Data.Int -import Data.Monoid -import Data.Scientific -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as LText -import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text.Lazy.Builder as Build -import qualified Data.Text.Lazy.Builder.Int as Build -import qualified Data.Text.Lazy.Builder.RealFloat as Build -import qualified Data.Text.Lazy.Builder.Scientific as Build -import Network.HTTP.Client -import Network.HTTP.Types -import Numeric.Natural - -fromText :: FromText a => Text -> Either String a -fromText = AText.parseOnly parser - -takeLowerText :: Parser Text -takeLowerText = Text.toLower <$> AText.takeText - -matchCI :: Text -> a -> Parser a -matchCI x y = AText.asciiCI x <* AText.endOfInput >> return y - -class FromText a where - parser :: Parser a - -instance FromText Text where parser = AText.takeText -instance FromText ByteString where parser = Text.encodeUtf8 <$> AText.takeText -instance FromText Int where parser = AText.signed AText.decimal -instance FromText Integer where parser = AText.signed AText.decimal -instance FromText Scientific where parser = AText.signed AText.scientific -instance FromText Natural where parser = AText.decimal -instance FromText Double where parser = AText.signed AText.rational - -instance FromText Bool where - parser = matchCI "false" False <|> matchCI "true" True - -showText :: ToText a => a -> String -showText = Text.unpack . toText - -class ToText a where - toText :: a -> Text - -instance (ToText a, ToText b) => ToText (a, b) where - toText (a, b) = "(" <> toText a <> ", " <> toText b <> ")" - -instance ToText a => ToText [a] where - toText xs = "[" <> Text.intercalate ", " (map toText xs) <> "]" - -instance ToText a => ToText (CI a) where - toText = toText . CI.original - -instance ToText (Response a) where - toText rs = Text.pack . show $ rs { responseBody = () } - -instance ToText Text where toText = id -instance ToText ByteString where toText = Text.decodeUtf8 -instance ToText Int where toText = shortText . Build.decimal -instance ToText Int64 where toText = shortText . Build.decimal -instance ToText Integer where toText = shortText . Build.decimal -instance ToText Natural where toText = shortText . Build.decimal -instance ToText Scientific where toText = shortText . Build.scientificBuilder -instance ToText Double where toText = shortText . Build.realFloat -instance ToText StdMethod where toText = toText . renderStdMethod -instance ToText (Digest a) where toText = toText . digestToHexByteString - -instance ToText Bool where - toText True = "true" - toText False = "false" - -shortText :: Builder -> Text -shortText = LText.toStrict . Build.toLazyTextWith 32 diff --git a/src/Network/AWS/Data/Internal/Time.hs b/src/Network/AWS/Data/Internal/Time.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/Time.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - --- Module : Network.AWS.Data.Internal.Time --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.Time - ( Format (..) - , Time (..) - , _Time - - , UTCTime - , RFC822 - , ISO8601 - , BasicTime - , AWSTime - , POSIX - - , parseTime - , defaultTimeLocale - , iso8601DateFormat - ) where - -import Control.Applicative -import Control.Lens -import Data.Aeson -import Data.Attoparsec.Text (Parser) -import qualified Data.Attoparsec.Text as AText -import qualified Data.ByteString.Char8 as BS -import Data.Scientific -import Data.Tagged -import qualified Data.Text as Text -import Data.Time (UTCTime) -import Data.Time.Clock.POSIX -import Data.Time.Format (formatTime) -import Network.AWS.Compat.Internal.Locale (defaultTimeLocale, - iso8601DateFormat) -import Network.AWS.Compat.Internal.Time (parseTime) -import Network.AWS.Data.Internal.ByteString -import Network.AWS.Data.Internal.JSON -import Network.AWS.Data.Internal.Query -import Network.AWS.Data.Internal.Text -import Network.AWS.Data.Internal.XML - -data Format - = RFC822Format - | ISO8601Format - | BasicFormat - | AWSFormat - | POSIXFormat - deriving (Eq, Read, Show) - -data Time :: Format -> * where - Time :: UTCTime -> Time a - -deriving instance Eq (Time a) -deriving instance Ord (Time a) -deriving instance Read (Time a) -deriving instance Show (Time a) - -_Time :: Iso' (Time a) UTCTime -_Time = iso (\(Time t) -> t) Time - -convert :: Time a -> Time b -convert (Time t) = Time t - -type RFC822 = Time 'RFC822Format -type ISO8601 = Time 'ISO8601Format -type BasicTime = Time 'BasicFormat -type AWSTime = Time 'AWSFormat -type POSIX = Time 'POSIXFormat - -class TimeFormat a where - format :: Tagged a String - -instance TimeFormat RFC822 where format = Tagged "%a, %d %b %Y %H:%M:%S GMT" -instance TimeFormat ISO8601 where format = Tagged (iso8601DateFormat (Just "%X%QZ")) -instance TimeFormat BasicTime where format = Tagged "%Y%m%d" -instance TimeFormat AWSTime where format = Tagged "%Y%m%dT%H%M%SZ" - -instance FromText BasicTime where parser = parseFormattedTime -instance FromText AWSTime where parser = parseFormattedTime - -instance FromText RFC822 where - parser = (convert :: ISO8601 -> RFC822) <$> parseFormattedTime - <|> parseFormattedTime - -instance FromText ISO8601 where - parser = (convert :: RFC822 -> ISO8601) <$> parseFormattedTime - <|> parseFormattedTime - -instance FromText POSIX where - parser = Time . posixSecondsToUTCTime . realToFrac - <$> (parser :: Parser Scientific) - -parseFormattedTime :: forall a. TimeFormat (Time a) => Parser (Time a) -parseFormattedTime = do - x <- Text.unpack <$> AText.takeText - p (parseTime defaultTimeLocale (untag f) x) x - where - p :: Maybe UTCTime -> String -> Parser (Time a) - p Nothing s = fail ("Unable to parse " ++ untag f ++ " from " ++ s) - p (Just x) _ = return (Time x) - - f :: Tagged (Time a) String - f = format - -instance ToText RFC822 where toText = Text.pack . renderFormattedTime -instance ToText ISO8601 where toText = Text.pack . renderFormattedTime -instance ToText BasicTime where toText = Text.pack . renderFormattedTime -instance ToText AWSTime where toText = Text.pack . renderFormattedTime - -instance ToText POSIX where - toText (Time t) = toText (truncate (utcTimeToPOSIXSeconds t) :: Integer) - -renderFormattedTime :: forall a. TimeFormat (Time a) => Time a -> String -renderFormattedTime (Time t) = formatTime defaultTimeLocale (untag f) t - where - f :: Tagged (Time a) String - f = format - -instance FromXML RFC822 where parseXML = parseXMLText "RFC822" -instance FromXML ISO8601 where parseXML = parseXMLText "ISO8601" -instance FromXML AWSTime where parseXML = parseXMLText "AWSTime" -instance FromXML BasicTime where parseXML = parseXMLText "BasicTime" -instance FromXML POSIX where parseXML = parseXMLText "POSIX" - -instance FromJSON RFC822 where parseJSON = parseJSONText "RFC822" -instance FromJSON ISO8601 where parseJSON = parseJSONText "ISO8601" -instance FromJSON AWSTime where parseJSON = parseJSONText "AWSTime" -instance FromJSON BasicTime where parseJSON = parseJSONText "BasicTime" - -instance FromJSON POSIX where - parseJSON = withScientific "POSIX" - $ pure - . Time - . posixSecondsToUTCTime - . realToFrac - -instance ToByteString RFC822 where toBS = BS.pack . renderFormattedTime -instance ToByteString ISO8601 where toBS = BS.pack . renderFormattedTime -instance ToByteString BasicTime where toBS = BS.pack . renderFormattedTime -instance ToByteString AWSTime where toBS = BS.pack . renderFormattedTime - -instance ToQuery RFC822 where toQuery = toQuery . toBS -instance ToQuery ISO8601 where toQuery = toQuery . toBS -instance ToQuery BasicTime where toQuery = toQuery . toBS -instance ToQuery AWSTime where toQuery = toQuery . toBS - -instance ToXML RFC822 where toXML = toXMLText -instance ToXML ISO8601 where toXML = toXMLText -instance ToXML AWSTime where toXML = toXMLText -instance ToXML BasicTime where toXML = toXMLText -instance ToXML POSIX where toXML = toXMLText - -instance ToJSON RFC822 where toJSON = toJSONText -instance ToJSON ISO8601 where toJSON = toJSONText -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 diff --git a/src/Network/AWS/Data/Internal/URI.hs b/src/Network/AWS/Data/Internal/URI.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/URI.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Module : Network.AWS.Data.Internal.URI --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.URI - ( collapsePath - ) where - -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.Foldable as Fold -import Data.Monoid - -collapsePath :: ByteString -> ByteString -collapsePath bs - | BS.null bs = slash - | BS.null path = slash - | otherwise = tl (hd path) - where - path = BS.intercalate slash - . reverse - . Fold.foldl' go [] - . filter (/= mempty) - $ BS.split sep bs - - hd x | BS.head x == sep = x - | otherwise = sep `BS.cons` x - - tl x | BS.last x == sep = x - | BS.last bs == sep = x `BS.snoc` sep - | otherwise = x - - go acc c | c == dot = acc - go acc c | c == dots = remv acc c - go acc c = c : acc - - remv [] _ = [] - remv (x : xs) c - | x == dot = c : xs - | x == dots = c : x : xs - | otherwise = xs - - dot = "." - dots = ".." - - slash = BS.singleton sep - - sep = '/' diff --git a/src/Network/AWS/Data/Internal/XML.hs b/src/Network/AWS/Data/Internal/XML.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Internal/XML.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- Module : Network.AWS.Data.Internal.XML --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Data.Internal.XML - ( - -- * FromXML - FromXML (..) - , decodeXML - , parseXMLText - , childNodes - , findElement - , withContent - , withElement - , localName - , (.@) - , (.@?) - , (.!@) - - -- * ToXML - , ToXML (..) - , ToXMLRoot (..) - , encodeXML - , toXMLText - , namespaced - , element - , nodes - , (=@) - , extractRoot - , unsafeToXML - ) where - -import Control.Applicative -import Control.Monad -import Data.Default.Class -import Data.Maybe -import Data.Monoid -import Data.Text (Text) -import Network.AWS.Data.Internal.ByteString -import Network.AWS.Data.Internal.Text -import Numeric.Natural -import Text.XML - -decodeXML :: LazyByteString -> Either String [Node] -decodeXML = either failure success . parseLBS def - where - failure = Left . show - success = Right . elementNodes . documentRoot - -encodeXML :: ToXMLRoot a => a -> LazyByteString -encodeXML = maybe mempty (renderLBS def . d) . toXMLRoot - where - d x = Document - { documentPrologue = p - , documentRoot = x - , documentEpilogue = [] - } - - p = Prologue - { prologueBefore = [] - , prologueDoctype = Nothing - , prologueAfter = [] - } - -parseXMLText :: FromText a => String -> [Node] -> Either String a -parseXMLText n = withContent n >=> maybe err fromText - where - err = Left $ "empty node list, when expecting single node " ++ n - -toXMLText :: ToText a => a -> [Node] -toXMLText x = [NodeContent (toText x)] - -(.@) :: FromXML a => [Node] -> Text -> Either String a -ns .@ n = findElement n ns >>= parseXML - -(.@?) :: FromXML a => [Node] -> Text -> Either String (Maybe a) -ns .@? n = - case findElement n ns of - Left _ -> Right Nothing - Right xs -> parseXML xs - -(.!@) :: Either String (Maybe a) -> a -> Either String a -f .!@ x = fromMaybe x <$> f - -namespaced :: Text -> Text -> [Node] -> Maybe Element -namespaced g l = Just . element (Name l (Just g) Nothing) - -element :: Name -> [Node] -> Element -element n = Element n mempty - -nodes :: Name -> [Node] -> [Node] -nodes n ns = [NodeElement (element n ns)] - -(=@) :: ToXML a => Name -> a -> Node -n =@ x = NodeElement (element n (toXML x)) - -extractRoot :: Text -> [Node] -> Maybe Element -extractRoot g ns = - case ns of - [NodeElement x] -> Just x { elementName = rename x } - _ -> Nothing - where - rename x = (elementName x) { nameNamespace = Just g } - --- | /Caution:/ This is for use with types which are 'flattened' in --- AWS service model terminology. --- --- It is applied by the generator/templating in safe contexts only. -unsafeToXML :: (Show a, ToXML a) => a -> Node -unsafeToXML x = - fromMaybe (error $ "Failed to unflatten node-list for: " ++ show x) - (listToMaybe (toXML x)) - -withContent :: String -> [Node] -> Either String (Maybe Text) -withContent n = exactly >=> \case - Just x -> Just <$> content x - Nothing -> return Nothing - where - exactly :: [Node] -> Either String (Maybe Node) - exactly = \case - [x] -> Right (Just x) - [] -> Right Nothing - _ -> Left $ - "encountered node list, when expecting exactly one node: " ++ n - - content :: Node -> Either String Text - content (NodeContent x) - = Right x - content (NodeElement e) - = let k = show (elementName e) - in Left $ "unexpected element " ++ k ++ ", when expecting node content: " ++ n - content _ = Left $ "unrecognised element, when expecting node content: " ++ n - -withElement :: Text -> ([Node] -> Either String a) -> [Node] -> Either String a -withElement n f = findElement n >=> f - -findElement :: Text -> [Node] -> Either String [Node] -findElement n ns = maybe err Right . listToMaybe $ mapMaybe (childNodes n) ns - where - err = Left $ "unable to find element " - ++ show n - ++ " in nodes " - ++ show (mapMaybe localName ns) - -childNodes :: Text -> Node -> Maybe [Node] -childNodes n (NodeElement e) - | nameLocalName (elementName e) == n = Just (elementNodes e) -childNodes _ _ = Nothing - -localName :: Node -> Maybe Text -localName (NodeElement e) = Just (nameLocalName (elementName e)) -localName _ = Nothing - -class FromXML a where - parseXML :: [Node] -> Either String a - -instance FromXML a => FromXML (Maybe a) where - parseXML [] = pure Nothing - parseXML ns = Just <$> parseXML ns - -instance FromXML Text where - parseXML = withContent "Text" >=> fromText . fromMaybe mempty - -instance FromXML Int where parseXML = parseXMLText "Int" -instance FromXML Integer where parseXML = parseXMLText "Integer" -instance FromXML Natural where parseXML = parseXMLText "Natural" -instance FromXML Double where parseXML = parseXMLText "Double" -instance FromXML Bool where parseXML = parseXMLText "Bool" - -class ToXMLRoot a where - toXMLRoot :: a -> Maybe Element - -class ToXML a where - toXML :: a -> [Node] - - default toXML :: ToXMLRoot a => a -> [Node] - toXML = maybeToList . fmap NodeElement . toXMLRoot - -instance ToXML a => ToXML (Maybe a) where - toXML (Just x) = toXML x - toXML Nothing = [] - -instance ToXML Text where toXML = toXMLText -instance ToXML Int where toXML = toXMLText -instance ToXML Integer where toXML = toXMLText -instance ToXML Natural where toXML = toXMLText -instance ToXML Double where toXML = toXMLText -instance ToXML Bool where toXML = toXMLText diff --git a/src/Network/AWS/Data/JSON.hs b/src/Network/AWS/Data/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/JSON.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.AWS.Data.JSON +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.JSON + ( + -- * FromJSON + FromJSON (..) + , parseJSONText + , eitherDecode' + + -- ** Parser a + , withObject + , (.:) + , (.:?) + , (.!=) + + -- ** Either String a + , eitherParseJSON + , (.:>) + , (.?>) + + -- * ToJSON + , ToJSON (..) + , toJSONText + , Value (Object) + , object + , (.=) + ) where + +import Data.Aeson (eitherDecode') +import Data.Aeson.Types +import qualified Data.HashMap.Strict as Map +import Network.AWS.Data.Text + +import Prelude + +parseJSONText :: FromText a => String -> Value -> Parser a +parseJSONText n = withText n (either fail return . fromText) + +toJSONText :: ToText a => a -> Value +toJSONText = String . toText + +eitherParseJSON :: FromJSON a => Object -> Either String a +eitherParseJSON = parseEither parseJSON . Object + +(.:>) :: FromJSON a => Object -> Text -> Either String a +(.:>) o k = + case Map.lookup k o of + Nothing -> Left $ "key " ++ show k ++ " not present" + Just v -> parseEither parseJSON v + +(.?>) :: FromJSON a => Object -> Text -> Either String (Maybe a) +(.?>) o k = + case Map.lookup k o of + Nothing -> Right Nothing + Just v -> parseEither parseJSON v diff --git a/src/Network/AWS/Data/List1.hs b/src/Network/AWS/Data/List1.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/List1.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Network.AWS.Data.List1 +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.List1 where + +import Control.Applicative +import Control.Lens (Iso', iso) +import Control.Monad +import Data.Aeson +import Data.Coerce +import Data.Data (Data, Typeable) +import Data.Foldable (Foldable) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Semigroup +import Data.Text (Text) +import Data.Traversable (Traversable, traverse) +import GHC.Exts +import GHC.Generics (Generic) +import Network.AWS.Data.XML +import Text.XML (Node) + +import Prelude + +newtype List1 a = List1 { toNonEmpty :: NonEmpty a } + deriving + ( Functor + , Monad + , Applicative + , Foldable + , Traversable + , Semigroup + , Eq + , Ord + , Read + , Show + , Data + , Typeable + , Generic + ) + +_List1 :: (Coercible a b, Coercible b a) => Iso' (List1 a) (NonEmpty b) +_List1 = iso (coerce . toNonEmpty) (List1 . coerce) + +instance IsList (List1 a) where + type Item (List1 a) = a + + fromList = List1 . NonEmpty.fromList + toList = NonEmpty.toList . toNonEmpty + +instance FromJSON a => FromJSON (List1 a) where + parseJSON = withArray "List1" (go >=> traverse parseJSON) + where + go = maybe (fail "Error parsing empty List1 when expecting at least one element.") + (pure . List1) + . NonEmpty.nonEmpty + . toList + +instance ToJSON a => ToJSON (List1 a) where + toJSON = toJSON . toList + +parseXMLList1 :: FromXML a + => Text + -> [Node] + -> Either String (List1 a) +parseXMLList1 n = parseXMLList n >=> parse + where + parse xs = + maybe (Left $ "Error parsing empty List1 when expecting at least one element: " ++ show n) + (Right . List1) + (NonEmpty.nonEmpty xs) diff --git a/src/Network/AWS/Data/Log.hs b/src/Network/AWS/Data/Log.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Log.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Network.AWS.Data.Log +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Log where + +import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Builder as Build +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Int +import Data.List (intersperse) +import Data.Monoid +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.Encoding as LText +import Data.Time (UTCTime) +import Data.Word +import GHC.Float +import Network.AWS.Data.ByteString +import Network.AWS.Data.Path +import Network.AWS.Data.Query +import Network.AWS.Data.Text +import Network.HTTP.Client +import Network.HTTP.Types +import Numeric + +import Prelude + +class ToLog a where + -- | Convert a value to a loggable builder. + build :: a -> Builder + +instance ToLog Builder where build = id +instance ToLog LBS.ByteString where build = Build.lazyByteString +instance ToLog ByteString where build = Build.byteString +instance ToLog Int where build = Build.intDec +instance ToLog Int8 where build = Build.int8Dec +instance ToLog Int16 where build = Build.int16Dec +instance ToLog Int32 where build = Build.int32Dec +instance ToLog Int64 where build = Build.int64Dec +instance ToLog Integer where build = Build.integerDec +instance ToLog Word where build = Build.wordDec +instance ToLog Word8 where build = Build.word8Dec +instance ToLog Word16 where build = Build.word16Dec +instance ToLog Word32 where build = Build.word32Dec +instance ToLog Word64 where build = Build.word64Dec +instance ToLog UTCTime where build = Build.stringUtf8 . show +instance ToLog Float where build = build . ($ "") . showFFloat Nothing +instance ToLog Double where build = build . ($ "") . showFFloat Nothing +instance ToLog Text where build = build . Text.encodeUtf8 +instance ToLog LText.Text where build = build . LText.encodeUtf8 +instance ToLog Char where build = build . Text.singleton +instance ToLog [Char] where build = build . LText.pack +instance ToLog StdMethod where build = build . renderStdMethod +instance ToLog QueryString where build = build . toBS +instance ToLog EscapedPath where build = build . toBS + +-- | Intercalate a list of 'Builder's with newlines. +buildLines :: [Builder] -> Builder +buildLines = mconcat . intersperse "\n" + +instance ToLog a => ToLog (CI a) where + build = build . CI.foldedCase + +instance ToLog a => ToLog (Maybe a) where + build Nothing = "Nothing" + build (Just x) = "Just " <> build x + +instance ToLog Bool where + build True = "True" + build False = "False" + +instance ToLog Status where + build x = build (statusCode x) <> " " <> build (statusMessage x) + +instance ToLog [Header] where + build = mconcat + . intersperse "; " + . map (\(k, v) -> build k <> ": " <> build v) + +instance ToLog HttpVersion where + build HttpVersion{..} = + "HTTP/" + <> build httpMajor + <> build '.' + <> build httpMinor + +instance ToLog RequestBody where + build = \case + RequestBodyBuilder n _ -> " build n <> ">" + RequestBodyStream n _ -> " build n <> ">" + RequestBodyStreamChunked _ -> " " + + RequestBodyLBS lbs + | n <= 4096 -> build lbs + | otherwise -> " build n <> ">" + where + n = LBS.length lbs + + RequestBodyBS bs + | n <= 4096 -> build bs + | otherwise -> " build n <> ">" + where + n = BS.length bs + +instance ToLog HttpException where + build x = "[HttpException] {\n" <> build (show x) <> "\n}" + +instance ToLog Request where + build x = buildLines + [ "[Client Request] {" + , " host = " <> build (host x) + , " port = " <> build (port x) + , " secure = " <> build (secure x) + , " headers = " <> build (requestHeaders x) + , " path = " <> build (path x) + , " query = " <> build (queryString x) + , " method = " <> build (method x) + , " timeout = " <> build (responseTimeout x) + , "}" + ] + +instance ToLog (Response a) where + build x = buildLines + [ "[Client Response] {" + , " status = " <> build (responseStatus x) + , " version = " <> build (responseVersion x) + , " headers = " <> build (responseHeaders x) + , " cookies = " <> build (show (responseCookieJar x)) + , "}" + ] diff --git a/src/Network/AWS/Data/Map.hs b/src/Network/AWS/Data/Map.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Map.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Network.AWS.Data.Map +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Map + ( Map (..) + , _Map + , parseXMLMap + , parseHeadersMap + , toQueryMap + ) where + +import Control.Applicative +import Control.Lens (Iso', iso) +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.Foldable hiding (toList) +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Maybe +import Data.Semigroup +import qualified Data.Text.Encoding as Text +import Data.Traversable +import GHC.Exts +import GHC.Generics (Generic) +import Network.AWS.Data.ByteString +import Network.AWS.Data.Headers +import Network.AWS.Data.Query +import Network.AWS.Data.Text +import Network.AWS.Data.XML +import Network.HTTP.Types (ResponseHeaders) +import Text.XML (Node) + +import Prelude + +newtype Map k v = Map { toMap :: HashMap k v } + deriving + ( Functor + , Foldable + , Traversable + , Monoid + , Semigroup + , Eq + , Read + , Show + , Data + , Typeable + , Generic + ) + +type role Map nominal representational + +_Map :: (Coercible a b, Coercible b a) => Iso' (Map k a) (HashMap k b) +_Map = iso (coerce . toMap) (Map . coerce) + +instance (Hashable k, Eq k) => IsList (Map k v) where + type Item (Map k v) = (k, v) + + fromList = Map . Map.fromList + toList = Map.toList . toMap + +instance (Eq k, Hashable k, FromText k, FromJSON v) => FromJSON (Map k v) where + parseJSON = withObject "HashMap" (fmap fromList . traverse f . toList) + where + f (k, v) = (,) + <$> either fail return (fromText k) + <*> parseJSON v + +instance (Eq k, Hashable k, ToText k, ToJSON v) => ToJSON (Map k v) where + toJSON = Object . fromList . map (bimap toText toJSON) . toList + +instance (Eq k, Hashable k, ToByteString k, ToText v) => ToHeader (Map k v) where + toHeader p = map (bimap k v) . toList + where + k = mappend p . CI.mk . toBS + v = Text.encodeUtf8 . toText + +parseXMLMap :: (Eq k, Hashable k, FromText k, FromXML v) + => Text + -> Text + -> Text + -> [Node] + -> Either String (Map k v) +parseXMLMap e k v = fmap fromList . traverse f . mapMaybe (childNodesOf e) + where + f ns = (,) + <$> (ns .@ k >>= fromText) + <*> ns .@ v + +parseHeadersMap :: FromText a + => ByteString + -> ResponseHeaders + -> Either String (Map Text a) +parseHeadersMap p = fmap fromList . traverse g . filter f + where + f = BS.isPrefixOf p . CI.foldedCase . fst + + g (k, v) = (Text.decodeUtf8 . BS.drop n $ CI.original k,) <$> + fromText (Text.decodeUtf8 v) + + n = BS.length p + +toQueryMap :: (Hashable k, Eq k, ToQuery k, ToQuery v) + => ByteString + -> ByteString + -> ByteString + -> Map k v + -> QueryString +toQueryMap e k v = toQueryList e . map f . toList + where + f (x, y) = QList [k =: toQuery x, v =: toQuery y] diff --git a/src/Network/AWS/Data/Numeric.hs b/src/Network/AWS/Data/Numeric.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Numeric.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Network.AWS.Data.Numeric +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Numeric where + +import Control.Lens +import Control.Monad +import Data.Aeson.Types +import Data.Data (Data, Typeable) +import Data.Monoid +import Data.Scientific +import GHC.Generics (Generic) +import Network.AWS.Data.ByteString +import Network.AWS.Data.Query +import Network.AWS.Data.Text +import Network.AWS.Data.XML +import Numeric.Natural + +import Prelude + +newtype Nat = Nat { unNat :: Natural } + deriving + ( Eq + , Ord + , Read + , Show + , Enum + , Num + , Real + , Integral + , Data + , Typeable + , Generic + , ToByteString + , FromText + , ToText + , FromXML + , ToXML + , ToQuery + ) + +_Nat :: Iso' Nat Natural +_Nat = iso unNat Nat + +instance FromJSON Nat where + parseJSON = parseJSON >=> go + where + go n = case floatingOrInteger n of + Left (_ :: Double) -> fail (floatErr n) + Right i + | n < 0 -> fail (negateErr n) + | otherwise -> return . Nat $ fromInteger i + + floatErr = mappend "Cannot convert float to Natural: " . show + negateErr = mappend "Cannot convert negative number to Natural: " . show + +instance ToJSON Nat where + toJSON = Number . flip scientific 0 . toInteger . unNat diff --git a/src/Network/AWS/Data/Path.hs b/src/Network/AWS/Data/Path.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Path.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | +-- Module : Network.AWS.Data.Path +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Path + ( + -- * Path Types + RawPath + , EscapedPath + + -- * Constructing Paths + , ToPath (..) + , rawPath + + -- * Manipulating Paths + , escapePath + , collapsePath + ) where + +import qualified Data.ByteString.Char8 as BS8 +import Data.Monoid +import Network.AWS.Data.ByteString +import Network.AWS.Data.Text +import Network.HTTP.Types.URI + +import Prelude + +class ToPath a where + toPath :: a -> ByteString + +instance ToPath ByteString where + toPath = id + +instance ToPath Text where + toPath = toBS + +rawPath :: ToPath a => a -> Path 'NoEncoding +rawPath = Raw . filter (not . BS8.null) . BS8.split sep . toPath + +data Encoding = NoEncoding | Percent + deriving (Eq, Show) + +data Path :: Encoding -> * where + Raw :: [ByteString] -> Path 'NoEncoding + Encoded :: [ByteString] -> Path 'Percent + +deriving instance Show (Path a) +deriving instance Eq (Path a) + +type RawPath = Path 'NoEncoding +type EscapedPath = Path 'Percent + +instance Monoid RawPath where + mempty = Raw [] + mappend (Raw xs) (Raw ys) = Raw (xs ++ ys) + +instance ToByteString EscapedPath where + toBS (Encoded []) = slash + toBS (Encoded xs) = slash <> BS8.intercalate slash xs + +escapePath :: Path a -> EscapedPath +escapePath (Raw xs) = Encoded (map (urlEncode True) xs) +escapePath (Encoded xs) = Encoded xs + +collapsePath :: Path a -> Path a +collapsePath = \case + Raw xs -> Raw (go xs) + Encoded xs -> Encoded (go xs) + where + go = reverse . f . reverse + + f :: [ByteString] -> [ByteString] + f [] = [] + f (x:xs) + | x == dot = f xs + | x == dots = drop 1 (f xs) + | otherwise = x : f xs + + dot = "." + dots = ".." + +slash :: ByteString +slash = BS8.singleton sep + +sep :: Char +sep = '/' diff --git a/src/Network/AWS/Data/Query.hs b/src/Network/AWS/Data/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Query.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Network.AWS.Data.Query +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Query where + +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 Data.Data +import Data.List (sort) +import Data.Monoid +import Data.String +import qualified Data.Text.Encoding as Text +import GHC.Exts +import Network.AWS.Data.ByteString +import Network.AWS.Data.Text +import Network.HTTP.Types.URI (urlEncode) +import Numeric.Natural + +import Prelude + +data QueryString + = QList [QueryString] + | QPair ByteString QueryString + | QValue (Maybe ByteString) + deriving (Eq, Show, Data, Typeable) + +instance Monoid QueryString where + mempty = QList [] + + mappend a b = case (a, b) of + (QList l, QList r) -> QList (l ++ r) + (QList l, r) -> QList (r : l) + (l, QList r) -> QList (l : r) + (l, r) -> QList [l, r] + +instance IsString QueryString where + fromString [] = mempty + fromString xs = QPair (BS8.pack xs) (QValue Nothing) + +-- FIXME: use Builder +instance ToByteString QueryString where + toBS = LBS.toStrict . Build.toLazyByteString . cat . sort . enc Nothing + where + enc :: Maybe ByteString -> QueryString -> [ByteString] + enc p = \case + QList xs -> concatMap (enc p) xs + + QPair (urlEncode True -> k) x + | Just n <- p -> enc (Just (n <> kdelim <> k)) x -- .key + | otherwise -> enc (Just k) x -- key + + QValue (Just (urlEncode True -> v)) + | Just n <- p -> [n <> vsep <> v] -- key=value + | otherwise -> [v <> vsep] -- value= -- note: required for signing. + + _ | Just n <- p -> [n <> vsep] -- key= + -- note: this case required for request signing + | otherwise -> [] + + cat :: [ByteString] -> Builder + cat [] = mempty + cat [x] = Build.byteString x + cat (x:xs) = Build.byteString x <> ksep <> cat xs + + kdelim = "." + ksep = "&" + vsep = "=" + +pair :: ToQuery a => ByteString -> a -> QueryString -> QueryString +pair k v = mappend (QPair k (toQuery v)) + +infixr 7 =: + +(=:) :: ToQuery a => ByteString -> a -> QueryString +k =: v = QPair k (toQuery v) + +toQueryList :: (IsList a, ToQuery (Item a)) + => ByteString + -> a + -> QueryString +toQueryList k = QPair k . QList . zipWith f [1..] . toList + where + f :: ToQuery a => Int -> a -> QueryString + f n v = toBS n =: toQuery v + +class ToQuery a where + toQuery :: a -> QueryString + + default toQuery :: ToText a => a -> QueryString + toQuery = toQuery . toText + +instance ToQuery QueryString where + toQuery = id + +instance (ToByteString k, ToQuery v) => ToQuery (k, v) where + toQuery (k, v) = QPair (toBS k) (toQuery v) + +instance ToQuery Char where + toQuery = toQuery . BS8.singleton + +instance ToQuery ByteString where + toQuery "" = QValue Nothing + toQuery bs = QValue (Just bs) + +instance ToQuery Text where toQuery = toQuery . Text.encodeUtf8 +instance ToQuery Int where toQuery = toQuery . toBS +instance ToQuery Integer where toQuery = toQuery . toBS +instance ToQuery Double where toQuery = toQuery . toBS +instance ToQuery Natural where toQuery = toQuery . toBS + +instance ToQuery a => ToQuery (Maybe a) where + toQuery (Just x) = toQuery x + toQuery Nothing = mempty + +instance ToQuery Bool where + toQuery True = toQuery ("true" :: ByteString) + toQuery False = toQuery ("false" :: ByteString) diff --git a/src/Network/AWS/Data/Sensitive.hs b/src/Network/AWS/Data/Sensitive.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Sensitive.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Network.AWS.Data.Sensitive +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Sensitive where + +import Control.Lens +import Data.Data (Data, Typeable) +import Data.Monoid +import Data.String +import GHC.Generics (Generic) +import Network.AWS.Data.ByteString +import Network.AWS.Data.JSON +import Network.AWS.Data.Query +import Network.AWS.Data.Text +import Network.AWS.Data.XML + +import Prelude + +-- | /Note/: read . show /= isomorphic +newtype Sensitive a = Sensitive { desensitise :: a } + deriving + ( Eq + , Ord + , Read + , IsString + , Monoid + , Data + , Typeable + , Generic + , ToByteString + , FromText + , ToText + , FromXML + , ToXML + , ToQuery + , ToJSON + , FromJSON + ) + +instance Show (Sensitive a) where + show = const "******" + +_Sensitive :: Iso' (Sensitive a) a +_Sensitive = iso desensitise Sensitive diff --git a/src/Network/AWS/Data/Text.hs b/src/Network/AWS/Data/Text.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Text.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-- | +-- Module : Network.AWS.Data.Text +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Text + ( Text + + -- * Deserialisation + , FromText (..) + , fromText + , fromTextError + , takeLowerText + , takeText + , matchCI + + -- * Serialisation + , ToText (..) + , toTextCI + , showText + ) where + +import Control.Applicative +import Data.Attoparsec.Text (Parser) +import qualified Data.Attoparsec.Text as A +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Int +import Data.Monoid +import Data.Scientific +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as LText +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as Build +import qualified Data.Text.Lazy.Builder.Int as Build +import qualified Data.Text.Lazy.Builder.Scientific as Build +import Network.AWS.Data.Crypto +import Network.HTTP.Types +import Numeric +import Numeric.Natural + +-- | Fail parsing with a 'Text' error. +-- +-- Constrained to the actual attoparsec monad to avoid +-- exposing 'fail' usage directly. +fromTextError :: Text -> Parser a +fromTextError = fail . Text.unpack + +fromText :: FromText a => Text -> Either String a +fromText = A.parseOnly parser + +takeLowerText :: Parser Text +takeLowerText = Text.toLower <$> A.takeText + +takeText :: Parser Text +takeText = A.takeText + +matchCI :: Text -> a -> Parser a +matchCI x y = A.asciiCI x <* A.endOfInput >> return y + +class FromText a where + parser :: Parser a + +instance FromText Text where + parser = A.takeText + +instance FromText ByteString where + parser = Text.encodeUtf8 <$> A.takeText + +instance FromText Char where + parser = A.anyChar <* A.endOfInput + +instance FromText Int where + parser = A.signed A.decimal <* A.endOfInput + +instance FromText Integer where + parser = A.signed A.decimal <* A.endOfInput + +instance FromText Scientific where + parser = A.signed A.scientific <* A.endOfInput + +instance FromText Natural where + parser = A.decimal <* A.endOfInput + +instance FromText Double where + parser = A.signed A.rational <* A.endOfInput + +instance FromText Bool where + parser = matchCI "false" False <|> matchCI "true" True + +instance FromText StdMethod where + parser = do + bs <- Text.encodeUtf8 <$> A.takeText + either (fail . BS8.unpack) pure (parseMethod bs) + +showText :: ToText a => a -> String +showText = Text.unpack . toText + +class ToText a where + toText :: a -> Text + +instance ToText a => ToText (CI a) where + toText = toText . CI.original + +instance ToText Text where toText = id +instance ToText ByteString where toText = Text.decodeUtf8 +instance ToText Char where toText = Text.singleton +instance ToText String where toText = Text.pack +instance ToText Int where toText = shortText . Build.decimal +instance ToText Int64 where toText = shortText . Build.decimal +instance ToText Integer where toText = shortText . Build.decimal +instance ToText Natural where toText = shortText . Build.decimal +instance ToText Scientific where toText = shortText . Build.scientificBuilder +instance ToText Double where toText = toText . ($ "") . showFFloat Nothing +instance ToText StdMethod where toText = toText . renderStdMethod +instance ToText (Digest a) where toText = toText . digestToBase Base16 + +instance ToText Bool where + toText True = "true" + toText False = "false" + +shortText :: Builder -> Text +shortText = LText.toStrict . Build.toLazyTextWith 32 + +toTextCI :: ToText a => a -> CI Text +toTextCI = CI.mk . toText diff --git a/src/Network/AWS/Data/Time.hs b/src/Network/AWS/Data/Time.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Time.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | +-- Module : Network.AWS.Data.Time +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Data.Time + ( + -- * Time + Format (..) + , Time (..) + , _Time + -- ** Formats + , UTCTime + , RFC822 + , ISO8601 + , BasicTime + , AWSTime + , POSIX + ) where + +import Control.Applicative +import Control.Lens +import Data.Aeson +import Data.Attoparsec.Text (Parser) +import qualified Data.Attoparsec.Text as AText +import qualified Data.ByteString.Char8 as BS +import Data.Data (Data, Typeable) +import Data.Monoid +import Data.Scientific +import Data.Tagged +import qualified Data.Text as Text +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX +import Data.Time.Format (formatTime) +import GHC.Generics (Generic) +import Network.AWS.Compat.Locale +import Network.AWS.Compat.Time +import Network.AWS.Data.ByteString +import Network.AWS.Data.JSON +import Network.AWS.Data.Query +import Network.AWS.Data.Text +import Network.AWS.Data.XML + +import Prelude + +data Format + = RFC822Format + | ISO8601Format + | BasicFormat + | AWSFormat + | POSIXFormat + deriving (Eq, Read, Show, Data, Typeable, Generic) + +deriving instance Typeable 'RFC822Format +deriving instance Typeable 'ISO8601Format +deriving instance Typeable 'BasicFormat +deriving instance Typeable 'AWSFormat +deriving instance Typeable 'POSIXFormat + +data Time :: Format -> * where + Time :: UTCTime -> Time a + deriving (Data, Typeable, Generic) + +deriving instance Eq (Time a) +deriving instance Ord (Time a) +deriving instance Read (Time a) +deriving instance Show (Time a) + +_Time :: Iso' (Time a) UTCTime +_Time = iso (\(Time t) -> t) Time + +convert :: Time a -> Time b +convert (Time t) = Time t + +type RFC822 = Time 'RFC822Format +type ISO8601 = Time 'ISO8601Format +type BasicTime = Time 'BasicFormat +type AWSTime = Time 'AWSFormat +type POSIX = Time 'POSIXFormat + +class TimeFormat a where + format :: Tagged a String + +instance TimeFormat RFC822 where format = Tagged "%a, %d %b %Y %H:%M:%S GMT" +instance TimeFormat ISO8601 where format = Tagged (iso8601DateFormat (Just "%X%Q%Z")) +instance TimeFormat BasicTime where format = Tagged "%Y%m%d" +instance TimeFormat AWSTime where format = Tagged "%Y%m%dT%H%M%SZ" + +instance FromText BasicTime where parser = parseFormattedTime +instance FromText AWSTime where parser = parseFormattedTime + +instance FromText RFC822 where + parser = (convert :: ISO8601 -> RFC822) <$> parseFormattedTime + <|> parseFormattedTime + +instance FromText ISO8601 where + parser = (convert :: RFC822 -> ISO8601) <$> parseFormattedTime + <|> parseFormattedTime + +instance FromText POSIX where + parser = Time . posixSecondsToUTCTime . realToFrac + <$> (parser :: Parser Scientific) + +parseFormattedTime :: forall a. TimeFormat (Time a) => Parser (Time a) +parseFormattedTime = do + x <- Text.unpack <$> AText.takeText + p (parseTime defaultTimeLocale (untag f) x) x + where + p :: Maybe UTCTime -> String -> Parser (Time a) + p (Just x) _ = return (Time x) + p Nothing s = fail $ mconcat + [ "Failure parsing Date format " + , untag f + , " from value: '" + , s + , "'" + ] + + f :: Tagged (Time a) String + f = format + +instance ToText RFC822 where toText = Text.pack . renderFormattedTime +instance ToText ISO8601 where toText = Text.pack . renderFormattedTime +instance ToText BasicTime where toText = Text.pack . renderFormattedTime +instance ToText AWSTime where toText = Text.pack . renderFormattedTime + +instance ToText POSIX where + toText (Time t) = toText (truncate (utcTimeToPOSIXSeconds t) :: Integer) + +renderFormattedTime :: forall a. TimeFormat (Time a) => Time a -> String +renderFormattedTime (Time t) = formatTime defaultTimeLocale (untag f) t + where + f :: Tagged (Time a) String + f = format + +instance FromXML RFC822 where parseXML = parseXMLText "RFC822" +instance FromXML ISO8601 where parseXML = parseXMLText "ISO8601" +instance FromXML AWSTime where parseXML = parseXMLText "AWSTime" +instance FromXML BasicTime where parseXML = parseXMLText "BasicTime" +instance FromXML POSIX where parseXML = parseXMLText "POSIX" + +instance FromJSON RFC822 where parseJSON = parseJSONText "RFC822" +instance FromJSON ISO8601 where parseJSON = parseJSONText "ISO8601" +instance FromJSON AWSTime where parseJSON = parseJSONText "AWSTime" +instance FromJSON BasicTime where parseJSON = parseJSONText "BasicTime" + +instance FromJSON POSIX where + parseJSON = withScientific "POSIX" + $ pure + . Time + . posixSecondsToUTCTime + . realToFrac + +instance ToByteString RFC822 where toBS = BS.pack . renderFormattedTime +instance ToByteString ISO8601 where toBS = BS.pack . renderFormattedTime +instance ToByteString BasicTime where toBS = BS.pack . renderFormattedTime +instance ToByteString AWSTime where toBS = BS.pack . renderFormattedTime + +instance ToQuery RFC822 where toQuery = toQuery . toBS +instance ToQuery ISO8601 where toQuery = toQuery . toBS +instance ToQuery BasicTime where toQuery = toQuery . toBS +instance ToQuery AWSTime where toQuery = toQuery . toBS + +instance ToXML RFC822 where toXML = toXMLText +instance ToXML ISO8601 where toXML = toXMLText +instance ToXML AWSTime where toXML = toXMLText +instance ToXML BasicTime where toXML = toXMLText +instance ToXML POSIX where toXML = toXMLText + +instance ToJSON RFC822 where toJSON = toJSONText +instance ToJSON ISO8601 where toJSON = toJSONText +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 diff --git a/src/Network/AWS/Data/XML.hs b/src/Network/AWS/Data/XML.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/XML.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Network.AWS.Data.XML +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +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 Prelude + +infixl 7 .@, .@? + +(.@) :: FromXML a => [Node] -> Text -> Either String a +ns .@ n = findElement n ns >>= parseXML + +(.@?) :: FromXML a => [Node] -> Text -> Either String (Maybe a) +ns .@? n = + case findElement n ns of + Left _ -> Right Nothing + Right xs -> parseXML xs + +infixr 7 @= + +(@=) :: ToXML a => Name -> a -> XML +n @= x = + case toXML x of + XNull -> XNull + xs -> XOne . NodeElement $ mkElement n xs + +decodeXML :: FromXML a => LazyByteString -> Either String a +decodeXML = either failure success . parseLBS def + where + failure = Left . show + success = parseXML . elementNodes . documentRoot + +-- The following is taken from xml-conduit.Text.XML which uses +-- unsafePerformIO anyway, with the following caveat: +-- 'not generally safe, but we know that runResourceT +-- will not deallocate any of the resources being used +-- by the process.' +encodeXML :: ToElement a => a -> LazyByteString +encodeXML x = LBS.fromChunks . unsafePerformIO . lazyConsume + $ Conduit.sourceList (toEvents doc) + =$= Conduit.map rename + =$= Stream.renderBytes def + where + doc = toXMLDocument $ Document + { documentRoot = root + , documentEpilogue = [] + , documentPrologue = + Prologue + { prologueBefore = [] + , prologueDoctype = Nothing + , prologueAfter = [] + } + } + + rename = \case + EventBeginElement n xs -> EventBeginElement (f n) (map (first f) xs) + EventEndElement n -> EventEndElement (f n) + evt -> evt + where + f n | isNothing (nameNamespace n) = n { nameNamespace = ns } + | otherwise = n + + ns = nameNamespace (elementName root) + root = toElement x + +class FromXML a where + parseXML :: [Node] -> Either String a + +instance FromXML [Node] where + parseXML = pure + +instance FromXML a => FromXML (Maybe a) where + parseXML [] = pure Nothing + parseXML ns = Just <$> parseXML ns + +instance FromXML Text where + parseXML = fmap (fromMaybe mempty) . withContent "Text" + +instance FromXML Char where parseXML = parseXMLText "Char" +instance FromXML ByteString where parseXML = parseXMLText "ByteString" +instance FromXML Int where parseXML = parseXMLText "Int" +instance FromXML Integer where parseXML = parseXMLText "Integer" +instance FromXML Natural where parseXML = parseXMLText "Natural" +instance FromXML Double where parseXML = parseXMLText "Double" +instance FromXML Bool where parseXML = parseXMLText "Bool" + +class ToElement a where + toElement :: a -> Element + +instance ToElement Element where + toElement = id + +-- | Provides a way to make the operators for ToXML instance +-- declaration be consistent WRT to single nodes or lists of nodes. +data XML + = XNull + | XOne Node + | XMany [Node] + deriving (Show) + +instance Monoid XML where + mempty = XNull + mappend XNull XNull = XNull + mappend a b = XMany (listXMLNodes a <> listXMLNodes b) + +listXMLNodes :: XML -> [Node] +listXMLNodes = \case + XNull -> [] + XOne n -> [n] + XMany ns -> ns + +class ToXML a where + toXML :: a -> XML + +toXMLNodes :: ToXML a => a -> [Node] +toXMLNodes = listXMLNodes . toXML + +instance ToXML XML where + toXML = id + +instance ToXML a => ToXML (Maybe a) where + toXML (Just x) = toXML x + toXML Nothing = XNull + +instance ToXML Text where toXML = toXMLText +instance ToXML ByteString where toXML = toXMLText +instance ToXML Int where toXML = toXMLText +instance ToXML Integer where toXML = toXMLText +instance ToXML Natural where toXML = toXMLText +instance ToXML Double where toXML = toXMLText +instance ToXML Bool where toXML = toXMLText + +parseXMLList :: FromXML a + => Text + -> [Node] + -> Either String [a] +parseXMLList n = traverse parseXML . mapMaybe (childNodesOf n) + +parseXMLText :: FromText a => String -> [Node] -> Either String a +parseXMLText n = withContent n >=> + maybe (Left $ "empty node list, when expecting single node " ++ n) + fromText + +toXMLList :: (IsList a, ToXML (Item a)) => Name -> a -> XML +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 + +withContent :: String -> [Node] -> Either String (Maybe Text) +withContent k = \case + [] -> Right Nothing + [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 + +findElement :: Text -> [Node] -> Either String [Node] +findElement n ns = + maybe (Left missing) Right . listToMaybe $ mapMaybe (childNodesOf n) ns + where + missing = "unable to find element " + ++ show n + ++ " in nodes " + ++ show (mapMaybe localName ns) + +childNodesOf :: Text -> Node -> Maybe [Node] +childNodesOf n x = case x of + NodeElement e + | Just n' <- localName x + , n == n' -> Just (elementNodes e) + _ -> Nothing + +localName :: Node -> Maybe Text +localName = \case + NodeElement e -> Just (nameLocalName (elementName e)) + _ -> Nothing diff --git a/src/Network/AWS/Endpoint.hs b/src/Network/AWS/Endpoint.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Endpoint.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Network.AWS.Types +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Endpoint where + +import qualified Data.CaseInsensitive as CI +import qualified Data.HashSet as Set +import Data.Monoid +import Network.AWS.Data.ByteString +import Network.AWS.Types + +import Prelude + +-- | Determine the full host address and credential scope for a 'Service' +-- within the specified 'Region'. +defaultEndpoint :: Service s -> Region -> Endpoint +defaultEndpoint Service{..} r = go (CI.mk _svcPrefix) + where + go = \case + "iam" + | china -> region "iam.cn-north-1.amazonaws.com.cn" + | govcloud -> region "iam.us-gov.amazonaws.com" + | otherwise -> global "iam.amazonaws.com" + + "sdb" + | virginia -> region "sdb.amazonaws.com" + + "sts" + | china -> region "sts.cn-north-1.amazonaws.com.cn" + | govcloud -> region ("sts." <> reg <> ".amazonaws.com") + | otherwise -> global "sts.amazonaws.com" + + "s3" + | virginia -> global "s3.amazonaws.com" + | china -> region ("s3." <> reg <> ".amazonaws.com.cn") + | s3 -> region ("s3-" <> reg <> ".amazonaws.com") + + "rds" + | virginia -> global "rds.amazonaws.com" + + "route53" + | not china -> global "route53.amazonaws.com" + + "emr" + | virginia -> global "elasticmapreduce.us-east-1.amazonaws.com" + | china -> region "elasticmapreduce.cn-north-1.amazonaws.com.cn" + | frankfurt -> region "elasticmapreduce.eu-central-1.amazonaws.com" + | otherwise -> region (reg <> ".elasticmapreduce.amazonaws.com") + + "sqs" + | virginia -> global "queue.amazonaws.com" + | china -> region (reg <> ".queue.amazonaws.com.cn") + + "importexport" + | not china -> region "importexport.amazonaws.com" + + "cloudfront" + | not china -> global "cloudfront.amazonaws.com" + + _ | china -> region (_svcPrefix <> "." <> reg <> ".amazonaws.com.cn") + | otherwise -> region (_svcPrefix <> "." <> reg <> ".amazonaws.com") + + virginia = r == NorthVirginia + frankfurt = r == Frankfurt + china = r == Beijing + govcloud = r == GovCloud || r == GovCloudFIPS + + s3 = r `Set.member` except + + region h = Endpoint { _endpointHost = h, _endpointScope = reg } + global h = Endpoint { _endpointHost = h, _endpointScope = "us-east-1" } + + reg = toBS r + + except = Set.fromList + [ GovCloud + , GovCloudFIPS + , Ireland + , NorthCalifornia + , NorthVirginia + , Oregon + , SaoPaulo + , Singapore + , Sydney + , Tokyo + ] 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 @@ -1,167 +1,137 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +-- | -- Module : Network.AWS.Error --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay --- Stability : experimental +-- Stability : provisional -- Portability : non-portable (GHC extensions) - -module Network.AWS.Error - ( - -- * Status Checks - statusSuccess - - -- * Classes - , AWSError (..) - , AWSErrorCode (..) - - -- * Types - , ErrorCode (..) - , ErrorType (..) - , ServiceError (..) - - -- * REST Errors - , RESTError - , restRequestId - , restType - , restCode - , restMessage - , restError - - -- * JSON Errors - , JSONError - , jsonType - , jsonCode - , jsonMessage - , jsonError - ) where +-- +module Network.AWS.Error where import Control.Applicative import Control.Lens +import Control.Monad import Data.Aeson -import qualified Data.ByteString.Lazy as LBS -import Data.ByteString.Lazy.Char8 (unpack) -import Data.String -import Data.Text (Text) -import GHC.Generics -import Network.AWS.Data +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Lazy as LBS +import Data.Maybe +import Data.Monoid +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Network.AWS.Data.ByteString +import Network.AWS.Data.Headers +import Network.AWS.Data.XML import Network.AWS.Types -import Network.HTTP.Types +import Network.HTTP.Client +import Network.HTTP.Types.Status (Status (..)) statusSuccess :: Status -> Bool -statusSuccess (statusCode -> n) = n >= 200 && n < 400 - -class AWSError a where - awsError :: a -> ServiceError String - -instance Show a => AWSError (ServiceError a) where - awsError = \case - HttpError e -> HttpError e - SerializerError a e -> SerializerError a e - ServiceError a s x -> ServiceError a s (show x) - Errors xs -> Errors (map awsError xs) +statusSuccess (statusCode -> n) = n >= 200 && n < 300 -newtype ErrorCode = ErrorCode Text - deriving (Eq, Ord, Show, FromXML, FromJSON, IsString, Generic) +httpStatus :: AsError a => Getting (First Status) a Status +httpStatus = _Error . f + where + f g = \case + TransportError (StatusCodeException s h c) + -> TransportError <$> (StatusCodeException <$> g s <*> pure h <*> pure c) + TransportError e + -> pure (TransportError e) + SerializeError (SerializeError' a s e) + -> g s <&> \x -> SerializeError (SerializeError' a x e) + ServiceError e + -> g (_serviceStatus e) <&> \x -> ServiceError (e { _serviceStatus = x }) -class AWSErrorCode a where - awsErrorCode :: a -> Maybe ErrorCode +hasStatus :: (Applicative f, Choice p) + => Int + -> Optic' p f ServiceError ServiceError +hasStatus n = filtered ((n ==) . fromEnum . _serviceStatus) -data ErrorType - = Receiver - | Sender - deriving (Eq, Ord, Enum, Show, Generic) +hasCode :: (Applicative f, Choice p) + => ErrorCode + -> Optic' p f ServiceError ServiceError +hasCode c = filtered ((c ==) . _serviceCode) -instance FromText ErrorType where - parser = takeLowerText >>= \case - "receiver" -> pure Receiver - "sender" -> pure Sender - e -> fail $ "Failure parsing ErrorType from " ++ show e +serviceError :: Abbrev + -> Status + -> [Header] + -> Maybe ErrorCode + -> Maybe ErrorMessage + -> Maybe RequestId + -> ServiceError +serviceError a s h c m r = + ServiceError' a s h (fromMaybe (getErrorCode s h) c) m (r <|> getRequestId h) -instance FromXML ErrorType where - parseXML = parseXMLText "Type" +getRequestId :: [Header] -> Maybe RequestId +getRequestId h = + either (const Nothing) Just (h .# hAMZRequestId <|> h .# hAMZNRequestId) -data RESTError = RESTError - { _restRequestId :: Text - , _restType :: Maybe ErrorType - , _restCode :: Maybe ErrorCode - , _restMessage :: Text - } deriving (Eq, Show, Generic) +getErrorCode :: Status -> [Header] -> ErrorCode +getErrorCode s h = + fromMaybe (ErrorCode . Text.decodeUtf8 $ statusMessage s) $ + case h .# hAMZNErrorType of + Left _ -> Nothing + Right t -> fmap ErrorCode . lastOf traverse $ Text.split (== '#') t -makeLenses ''RESTError +parseJSONError :: Abbrev + -> Status + -> [Header] + -> LazyByteString + -> Error +parseJSONError a s h bs = decodeError a s h bs (parse bs) + where + parse = eitherDecode' >=> parseEither (withObject "JSONError" go) -instance AWSErrorCode RESTError where - awsErrorCode = _restCode + go o = do + c <- (Just <$> o .: "__type") <|> o .:? "code" + m <- msg c o + return $! serviceError a s h c m Nothing -instance FromXML RESTError where - parseXML x = withElement "Error" f x <|> f x - where - f y = RESTError - <$> x .@ "RequestId" - <*> y .@? "Type" - <*> y .@? "Code" - <*> y .@ "Message" + msg c o = + if c == Just "RequestEntityTooLarge" + then pure (Just "Request body must be less than 1 MB") + else Just <$> o .: "message" + <|> o .:? "Message" -restError :: FromXML (Er a) - => (Status -> Bool) - -> Service a - -> Status - -> Maybe (LBS.ByteString -> ServiceError (Er a)) -restError f Service{..} s - | f s = Nothing - | otherwise = Just go +parseXMLError :: Abbrev + -> Status + -> [Header] + -> LazyByteString + -> Error +parseXMLError a s h bs = decodeError a s h bs (decodeXML bs >>= go) where - go x = either failure success (decodeXML x >>= parseXML) - where - failure e = SerializerError _svcAbbrev (e ++ ":\n" ++ unpack x) - success = ServiceError _svcAbbrev s - -data JSONError = JSONError - { _jsonType :: Maybe Text - , _jsonCode :: Maybe ErrorCode - , _jsonMessage :: Text - } deriving (Eq, Show, Generic) - -makeLenses ''JSONError + go x = do + (c, m, r) <- xml x <|> ec2 x + return $! serviceError a s h c m r -instance AWSErrorCode JSONError where - awsErrorCode = _jsonCode + xml x = withElement "Error" (gen x) x <|> gen x x + ec2 x = withElement "Errors" (gen x) x -instance FromJSON JSONError where - parseJSON = withObject "JSONError" $ \o -> rest o <|> post o - where - rest o = JSONError - <$> o .:? "Type" - <*> o .:? "Code" - <*> o .: "Message" + gen x y = (,,) + <$> y .@? "Code" + <*> y .@? "Message" + <*> x .@? "RequestId" - post o = JSONError - <$> o .:? "__type" - <*> o .:? "code" - <*> o .: "message" +parseRESTError :: Abbrev + -> Status + -> [Header] + -> a + -> Error +parseRESTError a s h _ = + ServiceError (serviceError a s h Nothing Nothing Nothing) -jsonError :: FromJSON (Er a) - => (Status -> Bool) - -> Service a - -> Status - -> Maybe (LBS.ByteString -> ServiceError (Er a)) -jsonError f Service{..} s - | f s = Nothing - | otherwise = Just go - where - go x = either failure success (eitherDecode' x) - where - failure e = SerializerError _svcAbbrev (e ++ ":\n" ++ unpack x) - success = ServiceError _svcAbbrev s +decodeError :: Abbrev + -> Status + -> [Header] + -> LazyByteString + -> Either String ServiceError + -> Error +decodeError a s h bs e + | LBS.null bs = parseRESTError a s h bs + | otherwise = + either (SerializeError . SerializeError' a s) + ServiceError + e diff --git a/src/Network/AWS/Pager.hs b/src/Network/AWS/Pager.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Pager.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.AWS.Pager +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Pager + ( AWSPager (..) + , AWSTruncated (..) + , stop + , choice + ) where + +import Control.Applicative +import Control.Lens hiding (index) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Text (Text) +import Network.AWS.Data.Text (ToText (..)) +import Network.AWS.Types + +import Prelude + +-- | Specify how an 'AWSRequest' and it's associated 'Rs' response can +-- generate a subsequent request, if available. +class AWSRequest a => AWSPager a where + page :: a -> Rs a -> Maybe a + +-- | Generalise IsTruncated and other optional/required +-- response pagination fields. +class AWSTruncated a where + truncated :: a -> Bool + +instance AWSTruncated Bool where + truncated = id + +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 + +stop :: AWSTruncated a => a -> Bool +stop = not . truncated + +choice :: (Alternative f, ToText a, ToText b) + => (s -> f a) + -> (s -> f b) + -> Getter s (f Text) +choice f g = to $ \x -> (toText <$> f x) <|> (toText <$> g x) diff --git a/src/Network/AWS/Pagination.hs b/src/Network/AWS/Pagination.hs deleted file mode 100644 --- a/src/Network/AWS/Pagination.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} - --- Module : Network.AWS.Pagination --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Pagination - ( more - , stop - , index - , choice - ) where - -import Control.Applicative -import Control.Lens hiding (index) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map -import Data.Text (Text) -import Network.AWS.Data (ToText(..)) - --- | Generalise IsTruncated and other optional/required --- response pagination fields. -class AWSMore a where - more :: a -> Bool - -instance AWSMore Bool where - more = id - -instance AWSMore (Maybe Bool) where - more (Just x) = x - more Nothing = False - -instance AWSMore (Maybe Text) where - more (Just _) = True - more Nothing = False - -instance AWSMore [a] where - more = not . null - -instance AWSMore (HashMap k v) where - more = not . Map.null - -stop :: AWSMore a => a -> Bool -stop = not . more - -index :: ToText c => Getter a [b] -> Getter b c -> Getter a (Maybe Text) -index f g = f . to lastMay . to (fmap (toText . view g)) - -choice :: Alternative f => (a -> f b) -> (a -> f b) -> a -> f b -choice f g x = f x <|> g x - -lastMay :: [a] -> Maybe a -lastMay [] = Nothing -lastMay (x:xs) = Just (go x xs) - where - go y [] = y - go _ (y:ys) = go y ys 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,92 +1,57 @@ --- Module : Network.AWS.Prelude.Types +-- | +-- Module : Network.AWS.Prelude -- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay --- Stability : experimental +-- Stability : provisional -- Portability : non-portable (GHC extensions) - +-- module Network.AWS.Prelude - ( - -- * Re-exported - module Export - - -- * Primitives - , ByteString - , CI - , ClientRequest - , ClientResponse - , Exception - , HashMap - , HttpException - , Natural - , NonEmpty (..) - , RequestBody - , Response - , Text - - -- * Classes - , AWSPager (..) - , AWSRequest (..) - , AWSService (..) - , Generic - , IsString (..) - , Semigroup - - -- * Retries - , Retry (..) - - -- * Errors - , AWSError (..) - , AWSErrorCode (..) - , ServiceError (..) - , RESTError - , restError - , JSONError - , jsonError - , statusSuccess - - -- * Shared - , Empty (..) - , Service (..) - - -- * HTTP - , StdMethod (..) - , Status (..) + ( module Network.AWS.Prelude + , module Export ) where -import Control.Exception (Exception) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import Data.HashMap.Strict (HashMap) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup (Semigroup) -import Data.String (IsString (..)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Network.AWS.Error -import Network.AWS.Types -import Network.HTTP.Client (HttpException, RequestBody) -import Network.HTTP.Types.Method (StdMethod (..)) -import Network.HTTP.Types.Status (Status (..)) -import Numeric.Natural (Natural) +import Control.Applicative as Export (Applicative, pure, + (<$>), (<*>), (<|>)) +import Control.Lens as Export hiding ((.=)) +import Data.Data as Export (Data, Typeable) +import Data.Foldable as Export (Foldable) +import Data.Hashable as Export (Hashable) +import Data.HashMap.Strict as Export (HashMap) +import Data.List.NonEmpty as Export (NonEmpty (..)) +import Data.Maybe as Export +import Data.Monoid as Export (First, mconcat, mempty, + (<>)) +import GHC.Generics as Export (Generic) +import Network.AWS.Data.Base64 as Export +import Network.AWS.Data.Body as Export +import Network.AWS.Data.ByteString as Export +import Network.AWS.Data.Crypto as Export hiding (Base (..)) +import Network.AWS.Data.Headers as Export +import Network.AWS.Data.JSON as Export +import Network.AWS.Data.List1 as Export +import Network.AWS.Data.Map as Export +import Network.AWS.Data.Numeric as Export +import Network.AWS.Data.Path as Export +import Network.AWS.Data.Query as Export +import Network.AWS.Data.Sensitive as Export +import Network.AWS.Data.Text as Export +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, + Endpoint, Seconds, + SecretKey) +import Network.HTTP.Types.Status as Export (Status (..)) +import Network.HTTP.Types.URI as Export (urlDecode, urlEncode) +import Numeric.Natural as Export (Natural) -import Control.Applicative as Export -import Data.Bifunctor as Export -import Data.Coerce as Export -import Data.Default.Class as Export -import Data.Hashable as Export -import Data.Maybe as Export -import Data.Monoid as Export hiding (All, Any, Sum) -import Data.Tagged as Export -import Network.AWS.Data as Export hiding (Object, Query) -import Network.AWS.Pagination as Export -import Network.AWS.Response as Export -import Prelude as Export hiding (error, head) +infixl 7 .!@ -import Control.Lens as Export (Iso', Lens', Prism', iso, - lens, mapping, prism, to, - withIso, (%~), (&), (.~), - (<>~), (?~), (^.)) +(.!@) :: Functor f => f (Maybe a) -> a -> f a +f .!@ x = fromMaybe x <$> f + +may :: Applicative f => ([a] -> f b) -> [a] -> f (Maybe b) +may _ [] = pure Nothing +may f xs = Just <$> f xs diff --git a/src/Network/AWS/Request.hs b/src/Network/AWS/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Request.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.AWS.Request +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Request + ( + -- * Requests + head' + , delete + , get + + -- ** Empty body + , post + , put + + -- ** Specialised body + , postXML + , postJSON + , postQuery + , postBody + + , putXML + , putJSON + , putBody + + -- ** Constructors + , defaultRequest + + -- ** Hashing + , contentSHA256 + , contentMD5 + + -- ** Lenses + , requestHeaders + , queryString + , requestURL + ) where + +import Control.Lens +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.JSON +import Network.AWS.Data.Path +import Network.AWS.Data.Query +import Network.AWS.Data.XML +import Network.AWS.Types +import qualified Network.HTTP.Client.Internal as Client +import Network.HTTP.Types (StdMethod (..)) +import qualified Network.HTTP.Types as HTTP + +head' :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +head' x = get x & rqMethod .~ HEAD + +delete :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +delete x = get x & rqMethod .~ DELETE + +get :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +get = contentSHA256 . defaultRequest + +post :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +post x = get x & rqMethod .~ POST + +put :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +put x = get x & rqMethod .~ PUT + +postXML :: (ToQuery a, ToPath a, ToHeaders a, ToElement a) => a -> Request a +postXML x = putXML x & rqMethod .~ POST + +postJSON :: (ToQuery a, ToPath a, ToHeaders a, ToJSON a) => a -> Request a +postJSON x = putJSON x & rqMethod .~ POST + +postQuery :: (ToQuery a, ToPath a, ToHeaders a) => a -> Request a +postQuery x = Request + { _rqMethod = POST + , _rqPath = rawPath x + , _rqQuery = mempty + , _rqBody = toBody (toQuery x) + , _rqHeaders = + hdr HTTP.hContentType "application/x-www-form-urlencoded; charset=utf-8" + (toHeaders x) + } & contentSHA256 + +postBody :: (ToPath a, ToQuery a, ToHeaders a, ToBody a) => a -> Request a +postBody x = putBody x & rqMethod .~ POST + +putXML :: (ToPath a, ToQuery a, ToHeaders a, ToElement a) => a -> Request a +putXML x = defaultRequest x + & rqMethod .~ PUT + & rqBody .~ toBody (toElement x) + & contentSHA256 + +putJSON :: (ToQuery a, ToPath a, ToHeaders a, ToJSON a) => a -> Request a +putJSON x = defaultRequest x + & rqMethod .~ PUT + & rqBody .~ toBody (toJSON x) + & contentSHA256 + +putBody :: (ToPath a, ToQuery a, ToHeaders a, ToBody a) => a -> Request a +putBody x = defaultRequest x + & rqMethod .~ PUT + & rqBody .~ toBody x + & contentSHA256 + +defaultRequest :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +defaultRequest x = Request + { _rqMethod = GET + , _rqPath = rawPath x + , _rqQuery = toQuery x + , _rqHeaders = toHeaders x + , _rqBody = "" + } + +contentSHA256 :: Request a -> Request a +contentSHA256 rq = rq & rqHeaders %~ + hdr hAMZContentSHA256 (rq ^. rqBody . to (digestToBase Base16 . bodySHA256)) + +contentMD5 :: Request a -> Request a +contentMD5 rq + | missing, Just x <- md5 = rq & rqHeaders %~ hdr HTTP.hContentMD5 x + | otherwise = rq + where + missing = isNothing $ lookup HTTP.hContentMD5 (rq ^. rqHeaders) + md5 = rq ^. rqBody . to (fmap (digestToBase Base64) . bodyCalculateMD5) + +queryString :: Lens' Client.Request ByteString +queryString f x = + f (Client.queryString x) <&> \y -> x { Client.queryString = y } + +requestHeaders :: Lens' Client.Request HTTP.RequestHeaders +requestHeaders f x = + f (Client.requestHeaders x) <&> \y -> x { Client.requestHeaders = y } + +requestURL :: ClientRequest -> ByteString +requestURL x = + scheme (Client.secure x) + <> toBS (Client.host x) + <> port (Client.port x) + <> toBS (Client.path x) + <> toBS (Client.queryString x) + where + scheme True = "https://" + scheme _ = "http://" + + port = \case + 80 -> "" + 443 -> "" + n -> ":" <> toBS n diff --git a/src/Network/AWS/Request/Internal.hs b/src/Network/AWS/Request/Internal.hs deleted file mode 100644 --- a/src/Network/AWS/Request/Internal.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Module : Network.AWS.Request.Internal --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Request.Internal - ( - -- * Requests - defaultRequest - - -- * Lenses - , method - , host - , path - , queryString - , requestBody - , requestHeaders - ) where - -import Control.Lens -import Data.ByteString (ByteString) -import Data.Default.Class -import qualified Data.Text.Encoding as Text -import Network.AWS.Data -import Network.AWS.Types -import qualified Network.HTTP.Client.Internal as HTTP -import qualified Network.HTTP.Types as HTTP - -defaultRequest :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a -defaultRequest x = def - & rqPath .~ Text.encodeUtf8 (toPath x) - & rqQuery .~ toQuery x - & rqHeaders .~ toHeaders x -{-# INLINE defaultRequest #-} - -method :: Lens' HTTP.Request HTTP.Method -method f x = f (HTTP.method x) <&> \y -> x { HTTP.method = y } -{-# INLINE method #-} - -host :: Lens' HTTP.Request ByteString -host f x = f (HTTP.host x) <&> \y -> x { HTTP.host = y } -{-# INLINE host #-} - -path :: Lens' HTTP.Request ByteString -path f x = f (HTTP.path x) <&> \y -> x { HTTP.path = y } -{-# INLINE path #-} - -queryString :: Lens' HTTP.Request ByteString -queryString f x = f (HTTP.queryString x) <&> \y -> x { HTTP.queryString = y } -{-# INLINE queryString #-} - -requestBody :: Lens' HTTP.Request HTTP.RequestBody -requestBody f x = f (HTTP.requestBody x) <&> \y -> x { HTTP.requestBody = y } -{-# INLINE requestBody #-} - -requestHeaders :: Lens' HTTP.Request HTTP.RequestHeaders -requestHeaders f x = - f (HTTP.requestHeaders x) <&> \y -> x { HTTP.requestHeaders = y } -{-# INLINE requestHeaders #-} diff --git a/src/Network/AWS/Request/JSON.hs b/src/Network/AWS/Request/JSON.hs deleted file mode 100644 --- a/src/Network/AWS/Request/JSON.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- Module : Network.AWS.Request.JSON --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Request.JSON - ( post - ) where - -import Control.Applicative -import Control.Lens hiding (Action) -import Data.Aeson -import Data.Monoid -import Network.AWS.Data -import Network.AWS.Request.Internal -import Network.AWS.Types -import Network.HTTP.Types.Header -import Network.HTTP.Types.Method - -post :: forall a. (AWSService (Sv a), ToQuery a, ToPath a, ToHeaders a, ToJSON a) - => Action - -> a - -> Request a -post a x = defaultRequest x - & rqMethod .~ POST - & rqHeaders <>~ hs - & rqBody .~ toBody (toJSON x) - where - hs = toHeader hAMZTarget target - ++ toHeader hContentType content - - target = (\p -> p <> "." <> toBS a) <$> _svcTargetPrefix svc - content = ("application/x-amz-json-" <>) <$> _svcJSONVersion svc - - svc :: Service (Sv a) - svc = service -{-# INLINE post #-} diff --git a/src/Network/AWS/Request/Query.hs b/src/Network/AWS/Request/Query.hs deleted file mode 100644 --- a/src/Network/AWS/Request/Query.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- Module : Network.AWS.Request.Query --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Request.Query - ( post - ) where - -import Control.Lens hiding (Action) -import Data.Monoid -import Network.AWS.Data -import Network.AWS.Request.Internal -import Network.AWS.Types -import Network.HTTP.Types.Method - -post :: forall a. (AWSService (Sv a), ToQuery a, ToPath a, ToHeaders a) - => Action - -> a - -> Request a -post a x = defaultRequest x & rqMethod .~ POST & rqQuery <>~ qry - where - qry = pair "Version" (_svcVersion svc) - . pair "Action" (toBS a) - $ mempty - - svc :: Service (Sv a) - svc = service -{-# INLINE post #-} diff --git a/src/Network/AWS/Request/RestJSON.hs b/src/Network/AWS/Request/RestJSON.hs deleted file mode 100644 --- a/src/Network/AWS/Request/RestJSON.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- Module : Network.AWS.Request.RestJSON --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Request.RestJSON - ( get - , delete - , post - , put - , stream - ) where - -import Control.Applicative -import Control.Lens hiding (Action) -import Data.Aeson -import Data.Monoid -import Network.AWS.Data -import Network.AWS.Request.Internal -import Network.AWS.Types -import Network.HTTP.Types.Header -import Network.HTTP.Types.Method - -get :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a -get = defaultRequest -{-# INLINE get #-} - -delete :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a -delete x = get x & rqMethod .~ DELETE -{-# INLINE delete #-} - -post :: (AWSService (Sv a), ToQuery a, ToPath a, ToHeaders a, ToJSON a) - => a - -> Request a -post x = put x & rqMethod .~ POST -{-# INLINE post #-} - -put :: forall a. (AWSService (Sv a), ToQuery a, ToPath a, ToHeaders a, ToJSON a) - => a - -> Request a -put x = get x - & rqMethod .~ PUT - & rqHeaders <>~ toHeader hContentType ct - & rqBody .~ toBody (toJSON x) - where - ct = ("application/x-amz-json-" <>) <$> _svcJSONVersion svc - - svc :: Service (Sv a) - svc = service -{-# INLINE put #-} - -stream :: (AWSService (Sv a), ToPath a, ToQuery a, ToHeaders a, ToBody a) - => StdMethod - -> a - -> Request a -stream m x = content $ get x & rqMethod .~ m & rqBody .~ toBody x -{-# INLINE stream #-} - -content :: Request a -> Request a -content rq = rq & rqHeaders %~ hdr hAMZContentSHA256 (bodyHash (rq ^. rqBody)) diff --git a/src/Network/AWS/Request/RestXML.hs b/src/Network/AWS/Request/RestXML.hs deleted file mode 100644 --- a/src/Network/AWS/Request/RestXML.hs +++ /dev/null @@ -1,44 +0,0 @@ --- Module : Network.AWS.Request.RestXML --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Request.RestXML - ( get - , head - , delete - , post - , put - ) where - -import Control.Lens -import Network.AWS.Data -import Network.AWS.Request.Internal -import Network.AWS.Types -import Network.HTTP.Types.Method -import Prelude hiding (head) - -get :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a -get = defaultRequest -{-# INLINE get #-} - -delete :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a -delete x = get x & rqMethod .~ DELETE -{-# INLINE delete #-} - -head :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a -head x = get x & rqMethod .~ HEAD -{-# INLINE head #-} - -post :: (ToPath a, ToQuery a, ToHeaders a, ToXMLRoot a) => a -> Request a -post x = put x & rqMethod .~ POST -{-# INLINE post #-} - -put :: (ToPath a, ToQuery a, ToHeaders a, ToXMLRoot a) => a -> Request a -put x = get x & rqMethod .~ PUT & rqBody .~ toBody (encodeXML x) -{-# INLINE put #-} diff --git a/src/Network/AWS/Request/S3.hs b/src/Network/AWS/Request/S3.hs deleted file mode 100644 --- a/src/Network/AWS/Request/S3.hs +++ /dev/null @@ -1,55 +0,0 @@ --- Module : Network.AWS.Request.S3 --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Request.S3 - ( get - , head - , delete - , post - , put - , stream - ) where - -import Control.Lens -import Network.AWS.Data -import Network.AWS.Request.Internal -import Network.AWS.Types -import Network.HTTP.Types.Method -import Prelude hiding (head) - -get :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a -get = content . defaultRequest -{-# INLINE get #-} - -delete :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a -delete x = get x & rqMethod .~ DELETE -{-# INLINE delete #-} - -head :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a -head x = get x & rqMethod .~ HEAD -{-# INLINE head #-} - -post :: (ToPath a, ToQuery a, ToHeaders a, ToXMLRoot a) => a -> Request a -post x = put x & rqMethod .~ POST -{-# INLINE post #-} - -put :: (ToPath a, ToQuery a, ToHeaders a, ToXMLRoot a) => a -> Request a -put x = content $ get x & rqMethod .~ PUT & rqBody .~ toBody (encodeXML x) -{-# INLINE put #-} - -stream :: (ToPath a, ToQuery a, ToHeaders a, ToBody a) - => StdMethod - -> a - -> Request a -stream m x = content $ get x & rqMethod .~ m & rqBody .~ toBody x -{-# INLINE stream #-} - -content :: Request a -> Request a -content rq = rq & rqHeaders %~ hdr hAMZContentSHA256 (bodyHash (rq ^. rqBody)) 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 @@ -1,144 +1,131 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +-- | -- Module : Network.AWS.Response --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay --- Stability : experimental +-- Stability : provisional -- Portability : non-portable (GHC extensions) - -module Network.AWS.Response - ( - -- * Responses - nullResponse - , headerResponse - , xmlResponse - , xmlHeaderResponse - , jsonResponse - , jsonHeaderResponse - , bodyResponse - ) where +-- +module Network.AWS.Response where -import Control.Applicative -import Control.Monad +import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Aeson -import Data.Bifunctor -import qualified Data.ByteString.Lazy as LBS import Data.Conduit import qualified Data.Conduit.Binary as Conduit import Data.Monoid -import Network.AWS.Data (FromXML (..), LazyByteString, - build, decodeXML) +import Data.Text (Text) +import Network.AWS.Data.Body +import Network.AWS.Data.ByteString +import Network.AWS.Data.Log +import Network.AWS.Data.XML import Network.AWS.Types import Network.HTTP.Client hiding (Request, Response) import Network.HTTP.Types import Text.XML (Node) -nullResponse :: (MonadResource m, AWSService (Sv a)) - => Rs a - -> Logger - -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) -nullResponse rs l = receive l $ \_ _ _ bdy -> - liftResourceT (bdy $$+- return (Right rs)) - -headerResponse :: (MonadResource m, AWSService (Sv a)) - => (ResponseHeaders -> Either String (Rs a)) - -> Logger - -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) -headerResponse f = deserialise (const (Right ())) (\hs _ _ -> f hs) +import Prelude -xmlResponse :: (MonadResource m, AWSService (Sv a), FromXML (Rs a)) - => Logger +receiveNull :: MonadResource m + => Rs a + -> Logger + -> Service s -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) -xmlResponse = deserialise (decodeXML >=> parseXML) (\_ _ -> Right) + -> ClientResponse + -> m (Response a) +receiveNull rs _ = receive $ \_ _ x -> + liftResourceT (x $$+- return (Right rs)) -xmlHeaderResponse :: (MonadResource m, AWSService (Sv a)) - => (ResponseHeaders -> [Node] -> Either String (Rs a)) +receiveEmpty :: MonadResource m + => (Int -> ResponseHeaders -> () -> Either String (Rs a)) + -> Logger + -> Service s + -> Request a + -> ClientResponse + -> m (Response a) +receiveEmpty f _ = receive $ \s h x -> + liftResourceT (x $$+- return (f s h ())) + +receiveXMLWrapper :: MonadResource m + => Text + -> (Int -> ResponseHeaders -> [Node] -> Either String (Rs a)) -> Logger + -> Service s -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) -xmlHeaderResponse f = deserialise decodeXML (\hs _ -> f hs) + -> ClientResponse + -> m (Response a) +receiveXMLWrapper n f = receiveXML (\s h x -> x .@ n >>= f s h) -jsonResponse :: (MonadResource m, AWSService (Sv a), FromJSON (Rs a)) - => Logger - -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) -jsonResponse = deserialise eitherDecode' (\_ _ -> Right) +receiveXML :: MonadResource m + => (Int -> ResponseHeaders -> [Node] -> Either String (Rs a)) + -> Logger + -> Service s + -> Request a + -> ClientResponse + -> m (Response a) +receiveXML = deserialise decodeXML -jsonHeaderResponse :: (MonadResource m, AWSService (Sv a)) - => (ResponseHeaders -> Int -> Object -> Either String (Rs a)) - -> Logger - -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) -jsonHeaderResponse = deserialise eitherDecode' +receiveJSON :: MonadResource m + => (Int -> ResponseHeaders -> Object -> Either String (Rs a)) + -> Logger + -> Service s + -> Request a + -> ClientResponse + -> m (Response a) +receiveJSON = deserialise eitherDecode' -bodyResponse :: (MonadResource m, AWSService (Sv a)) - => (ResponseHeaders -> Int -> ResponseBody -> Either String (Rs a)) - -> Logger - -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) -bodyResponse f l = receive l $ \a hs s bdy -> - return (SerializerError a `first` f hs s bdy) +receiveBody :: MonadResource m + => (Int -> ResponseHeaders -> RsBody -> Either String (Rs a)) + -> Logger + -> Service s + -> Request a + -> ClientResponse + -> m (Response a) +receiveBody f _ = receive $ \s h x -> return (f s h (RsBody x)) -deserialise :: (AWSService (Sv a), MonadResource m) - => (LazyByteString -> Either String b) - -> (ResponseHeaders -> Int -> b -> Either String (Rs a)) +deserialise :: MonadResource m + => (LazyByteString -> Either String b) + -> (Int -> ResponseHeaders -> b -> Either String (Rs a)) -> Logger + -> Service s -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) -deserialise g f l = receive l $ \a hs s bdy -> do - lbs <- sinkLbs l bdy - return $! case g lbs of - Left e -> Left (SerializerError a e) - Right o -> - case f hs s o of - Left e -> Left (SerializerError a e) - Right x -> Right x + -> ClientResponse + -> m (Response a) +deserialise g f l = receive $ \s h x -> do + lbs <- sinkLBS x + liftIO . l Debug . build $ "[Raw Response Body] {\n" <> lbs <> "\n}" + return $! g lbs >>= f s h -receive :: forall m a. (MonadResource m, AWSService (Sv a)) - => Logger - -> (Abbrev -> ResponseHeaders -> Int -> ResponseBody -> m (Response a)) +receive :: MonadResource m + => (Int -> ResponseHeaders -> ResponseBody -> m (Either String (Rs a))) + -> Service s -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) -receive l f = const (either (return . Left . HttpError) success) + -> ClientResponse + -> m (Response a) +receive f Service{..} _ rs + | not (_svcStatus s) = sinkLBS x >>= serviceErr + | otherwise = do + p <- f (fromEnum s) h x + either serializeErr + (return . (s,)) + p where - success rs = do - let s = responseStatus rs - bdy = responseBody rs - hs = responseHeaders rs - case _svcHandle svc s of - Just g -> Left . g <$> sinkLbs l bdy - Nothing -> do - x <- f (_svcAbbrev svc) hs (fromEnum s) bdy - case x of - Left e -> return (Left e) - Right y -> return (Right (s, y)) + s = responseStatus rs + h = responseHeaders rs + x = responseBody rs - svc = service :: Service (Sv a) + serviceErr :: MonadThrow m => LazyByteString -> m a + serviceErr = throwM . _svcError _svcAbbrev s h -sinkLbs :: MonadResource m => Logger -> ResponseBody -> m LBS.ByteString -sinkLbs l bdy = do - lbs <- liftResourceT (bdy $$+- Conduit.sinkLbs) - liftIO $ l Trace ("[Client Response Body] {\n" <> build lbs <> "\n}") - return lbs + serializeErr :: MonadThrow m => String -> m a + serializeErr e = throwM (SerializeError (SerializeError' _svcAbbrev s e)) + +sinkLBS :: MonadResource m => ResponseBody -> m LazyByteString +sinkLBS bdy = liftResourceT (bdy $$+- Conduit.sinkLbs) diff --git a/src/Network/AWS/Sign/V2.hs b/src/Network/AWS/Sign/V2.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Sign/V2.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Network.AWS.Sign.V2 +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Sign.V2 + ( V2 + , Meta (..) + ) where + +import Control.Applicative +import qualified Data.ByteString.Char8 as BS8 +import Data.List (intersperse) +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.Query +import Network.AWS.Data.Time +import Network.AWS.Types +import qualified Network.HTTP.Client.Internal as Client +import Network.HTTP.Types hiding (toQuery) + +import Prelude + +data V2 + +data instance Meta V2 = Meta + { metaTime :: !UTCTime + , metaEndpoint :: !Endpoint + , metaSignature :: !ByteString + } + +instance ToLog (Meta V2) where + build Meta{..} = mconcat $ intersperse "\n" + [ "[Version 2 Metadata] {" + , " time = " <> build metaTime + , " endpoint = " <> build (_endpointHost metaEndpoint) + , " signature = " <> build metaSignature + , "}" + ] + +instance AWSSigner V2 where + signed AuthEnv{..} r t Service{..} Request{..} = Signed meta rq + where + meta = Meta t end signature + + rq = clientRequest + { Client.method = meth + , Client.host = _endpointHost + , Client.path = path' + , Client.queryString = toBS authorised + , Client.requestHeaders = headers + , Client.requestBody = bodyRequest _rqBody + } + + meth = toBS _rqMethod + path' = toBS (escapePath _rqPath) + + end@Endpoint{..} = _svcEndpoint r + + authorised = pair "Signature" (urlEncode True signature) query + + signature = digestToBase Base64 + . hmacSHA256 (toBS _authSecret) + $ BS8.intercalate "\n" + [ meth + , _endpointHost + , path' + , toBS query + ] + + query = + pair "Version" _svcVersion + . pair "SignatureVersion" ("2" :: ByteString) + . pair "SignatureMethod" ("HmacSHA256" :: ByteString) + . pair "Timestamp" time + . pair "AWSAccessKeyId" (toBS _authAccess) + $ _rqQuery <> maybe mempty toQuery token + + token = ("SecurityToken" :: ByteString,) . toBS <$> _authToken + + headers = hdr hDate time _rqHeaders + + time = toBS (Time t :: ISO8601) diff --git a/src/Network/AWS/Sign/V4.hs b/src/Network/AWS/Sign/V4.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Sign/V4.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Network.AWS.Sign.V4 +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Sign.V4 + ( V4 + , Meta (..) + ) where + +import Control.Applicative +import Control.Lens +import Data.Bifunctor +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.Monoid +import GHC.TypeLits +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.Query +import Network.AWS.Data.Time +import Network.AWS.Request +import Network.AWS.Types +import qualified Network.HTTP.Client.Internal as Client +import Network.HTTP.Types.Header + +import Prelude + +data V4 + +data instance Meta V4 = Meta + { metaTime :: !UTCTime + , metaMethod :: !Method + , metaPath :: !Path + , metaEndpoint :: !Endpoint + , metaCredential :: !Credential + , metaCanonicalQuery :: !CanonicalQuery + , metaCanonicalRequest :: !CanonicalRequest + , metaCanonicalHeaders :: !CanonicalHeaders + , metaSignedHeaders :: !SignedHeaders + , metaStringToSign :: !StringToSign + , metaSignature :: !Signature + , metaHeaders :: ![Header] + , metaBody :: Client.RequestBody + } + +instance ToLog (Meta V4) where + build Meta{..} = buildLines + [ "[Version 4 Metadata] {" + , " time = " <> build metaTime + , " endpoint = " <> build (_endpointHost metaEndpoint) + , " credential = " <> build metaCredential + , " signed headers = " <> build metaSignedHeaders + , " signature = " <> build metaSignature + , " string to sign = {" + , build metaStringToSign + , "}" + , " canonical request = {" + , build metaCanonicalRequest + , " }" + , "}" + ] + +instance AWSPresigner V4 where + presigned auth reg ts ex svc rq = finalise meta authorise + where + authorise = queryString + <>~ ("&X-Amz-Signature=" <> toBS (metaSignature meta)) + + meta = sign auth reg ts svc presign digest (prepare rq) + + presign c shs = + pair (CI.original hAMZAlgorithm) algorithm + . pair (CI.original hAMZCredential) (toBS c) + . pair (CI.original hAMZDate) (Time ts :: AWSTime) + . pair (CI.original hAMZExpires) ex + . pair (CI.original hAMZSignedHeaders) (toBS shs) + . pair (CI.original hAMZToken) (toBS <$> _authToken auth) + + digest = Tag "UNSIGNED-PAYLOAD" + + prepare = rqHeaders .~ [] + +instance AWSSigner V4 where + signed auth reg ts svc rq = finalise meta authorise + where + authorise = requestHeaders + <>~ [(hAuthorization, authorisation meta)] + + meta = sign auth reg ts svc presign digest (prepare rq) + + presign _ _ = id + + digest = Tag . digestToBase Base16 . bodySHA256 $ _rqBody rq + + prepare = rqHeaders %~ + ( hdr hHost (_endpointHost (_svcEndpoint svc reg)) + . hdr hAMZDate (toBS (Time ts :: AWSTime)) + . maybe id (hdr hAMZToken . toBS) (_authToken auth) + ) + +-- | Used to tag provenance. This allows keeping the same layout as +-- the signing documentation, passing 'ByteString's everywhere, with +-- some type guarantees. +-- +-- Data.Tagged is not used for no reason other than syntactic length and +-- the ToByteString instance. +newtype Tag (s :: Symbol) a = Tag { unTag :: a } + +instance ToByteString (Tag s ByteString) where toBS = unTag +instance ToLog (Tag s ByteString) where build = build . unTag + +instance ToByteString CredentialScope where + toBS = BS8.intercalate "/" . unTag + +type Hash = Tag "body-digest" ByteString +type StringToSign = Tag "string-to-sign" ByteString +type Credential = Tag "credential" ByteString +type CredentialScope = Tag "credential-scope" [ByteString] +type CanonicalRequest = Tag "canonical-request" ByteString +type CanonicalHeaders = Tag "canonical-headers" ByteString +type CanonicalQuery = Tag "canonical-query" ByteString +type SignedHeaders = Tag "signed-headers" ByteString +type NormalisedHeaders = Tag "normalised-headers" [(ByteString, ByteString)] +type Method = Tag "method" ByteString +type Path = Tag "path" ByteString +type Signature = Tag "signature" ByteString + +authorisation :: Meta V4 -> ByteString +authorisation Meta{..} = algorithm + <> " Credential=" <> toBS metaCredential + <> ", SignedHeaders=" <> toBS metaSignedHeaders + <> ", Signature=" <> toBS metaSignature + +finalise :: Meta V4 -> (ClientRequest -> ClientRequest) -> Signed V4 a +finalise meta authorise = Signed meta . authorise $ clientRequest + { Client.method = toBS (metaMethod meta) + , Client.host = _endpointHost (metaEndpoint meta) + , Client.path = toBS (metaPath meta) + , Client.queryString = '?' `BS8.cons` toBS (metaCanonicalQuery meta) + , Client.requestHeaders = metaHeaders meta + , Client.requestBody = metaBody meta + } + +sign :: AuthEnv + -> Region + -> UTCTime + -> Service s + -> (Credential -> SignedHeaders -> QueryString -> QueryString) + -> Hash + -> Request a + -> Meta V4 +sign auth reg ts svc presign digest rq = Meta + { metaTime = ts + , metaMethod = method + , metaPath = path + , metaEndpoint = end + , metaCredential = cred + , metaCanonicalQuery = query + , metaCanonicalRequest = crq + , metaCanonicalHeaders = chs + , metaSignedHeaders = shs + , metaStringToSign = sts + , metaSignature = signature (_authSecret auth) scope sts + , metaHeaders = _rqHeaders rq + , metaBody = bodyRequest (_rqBody rq) + } + where + query = canonicalQuery . presign cred shs $ _rqQuery rq + + sts = stringToSign ts scope crq + cred = credential (_authAccess auth) scope + scope = credentialScope svc end ts + crq = canonicalRequest method path digest query chs shs + + chs = canonicalHeaders headers + shs = signedHeaders headers + headers = normaliseHeaders (_rqHeaders rq) + + end = _svcEndpoint svc reg + method = Tag . toBS $ _rqMethod rq + path = escapedPath svc rq + +algorithm :: ByteString +algorithm = "AWS4-HMAC-SHA256" + +signature :: SecretKey -> CredentialScope -> StringToSign -> Signature +signature k c = Tag . digestToBase Base16 . hmacSHA256 signingKey . unTag + where + signingKey = Fold.foldl' hmac ("AWS4" <> toBS k) (unTag c) + + hmac x y = digestToBS (hmacSHA256 x y) + +stringToSign :: UTCTime -> CredentialScope -> CanonicalRequest -> StringToSign +stringToSign t c r = Tag $ BS8.intercalate "\n" + [ algorithm + , toBS (Time t :: AWSTime) + , toBS c + , digestToBase Base16 . hashSHA256 $ toBS r + ] + +credential :: AccessKey -> CredentialScope -> Credential +credential k c = Tag (toBS k <> "/" <> toBS c) + +credentialScope :: Service s -> Endpoint -> UTCTime -> CredentialScope +credentialScope s e t = Tag + [ toBS (Time t :: BasicTime) + , toBS (_endpointScope e) + , toBS (_svcPrefix s) + , "aws4_request" + ] + +canonicalRequest :: Method + -> Path + -> Hash + -> CanonicalQuery + -> CanonicalHeaders + -> SignedHeaders + -> CanonicalRequest +canonicalRequest meth path digest query chs shs = Tag $ + BS8.intercalate "\n" + [ toBS meth + , toBS path + , toBS query + , toBS chs + , toBS shs + , toBS digest + ] + +escapedPath :: Service s -> Request a -> Path +escapedPath s r = Tag . toBS . escapePath $ + case _svcAbbrev s of + "S3" -> _rqPath r + _ -> collapsePath (_rqPath r) + +canonicalQuery :: QueryString -> CanonicalQuery +canonicalQuery = Tag . toBS + +-- FIXME: the following use of stripBS is too naive, should remove +-- all internal whitespace, replacing with a single space char, +-- unless quoted with \"...\" +canonicalHeaders :: NormalisedHeaders -> CanonicalHeaders +canonicalHeaders = Tag . Fold.foldMap (uncurry f) . unTag + where + f k v = k <> ":" <> stripBS v <> "\n" + +signedHeaders :: NormalisedHeaders -> SignedHeaders +signedHeaders = Tag . BS8.intercalate ";" . map fst . unTag + +normaliseHeaders :: [Header] -> NormalisedHeaders +normaliseHeaders = Tag + . map (first CI.foldedCase) + . nubBy ((==) `on` fst) + . sortBy (compare `on` fst) + . filter ((/= "authorization") . fst) diff --git a/src/Network/AWS/Signing.hs b/src/Network/AWS/Signing.hs deleted file mode 100644 --- a/src/Network/AWS/Signing.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- Module : Network.AWS.Signing.Internal --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Signing - ( - -- * Version 2 - V2 - - -- * Version 4 - , V4 - - -- * Signing functions - , sign - , presign - ) where - -import Network.AWS.Signing.Internal -import Network.AWS.Signing.Internal.V2 -import Network.AWS.Signing.Internal.V4 diff --git a/src/Network/AWS/Signing/Internal.hs b/src/Network/AWS/Signing/Internal.hs deleted file mode 100644 --- a/src/Network/AWS/Signing/Internal.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- Module : Network.AWS.Signing.Internal --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Signing.Internal where - -import Control.Monad.IO.Class -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.MAC.HMAC as HMAC -import Data.ByteString (ByteString) -import Data.Time -import Network.AWS.Types - -sign :: (MonadIO m, AWSRequest a, AWSSigner (Sg (Sv a))) - => Auth -- ^ AWS authentication credentials. - -> Region -- ^ AWS Region. - -> Request a -- ^ Request to sign. - -> UTCTime -- ^ Signing time. - -> m (Signed a (Sg (Sv a))) -sign a r rq t = withAuth a $ \e -> return (signed e r rq t) - -presign :: (MonadIO m, AWSRequest a, AWSPresigner (Sg (Sv a))) - => Auth -- ^ AWS authentication credentials. - -> Region -- ^ AWS Region. - -> Request a -- ^ Request to presign. - -> UTCTime -- ^ Signing time. - -> Integer -- ^ Expiry time in seconds. - -> m (Signed a (Sg (Sv a))) -presign a r rq t ex = withAuth a $ \e -> return (presigned e r rq t ex) - -hmacSHA256 :: ByteString -> ByteString -> ByteString -hmacSHA256 = HMAC.hmac SHA256.hash 64 diff --git a/src/Network/AWS/Signing/Internal/V2.hs b/src/Network/AWS/Signing/Internal/V2.hs deleted file mode 100644 --- a/src/Network/AWS/Signing/Internal/V2.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - --- Module : Network.AWS.Signaing.Internal.V2 --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Signing.Internal.V2 - ( V2 - ) where - -import Control.Applicative -import Control.Lens -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base64 as Base64 -import qualified Data.ByteString.Char8 as BS -import Data.List (intersperse) -import Data.Monoid -import Data.Time -import Network.AWS.Data -import Network.AWS.Request.Internal -import Network.AWS.Signing.Internal -import Network.AWS.Types -import Network.HTTP.Types hiding (toQuery) - -data V2 - -data instance Meta V2 = Meta - { _mSignature :: ByteString - , _mTime :: UTCTime - } - -instance ToBuilder (Meta V2) where - build Meta{..} = mconcat $ intersperse "\n" - [ "[Version 2 Metadata] {" - , " signature = " <> build _mSignature - , " time = " <> build _mTime - , "}" - ] - -instance AWSSigner V2 where - signed AuthEnv{..} r x@Request{..} t = Signed meta rq - where - meta = Meta - { _mSignature = signature - , _mTime = t - } - - rq = clientRequest - & method .~ meth - & host .~ _endpointHost - & path .~ _rqPath - & queryString .~ toBS authorised - & requestHeaders .~ headers - & requestBody .~ _bdyBody _rqBody - - meth = toBS _rqMethod - - Endpoint{..} = endpoint svc r - - authorised = pair "Signature" (urlEncode True signature) query - - signature = Base64.encode - . hmacSHA256 (toBS _authSecret) - $ BS.intercalate "\n" - [ meth - , _endpointHost - , _rqPath - , toBS query - ] - - query = - pair "Version" (_svcVersion svc) - . pair "SignatureVersion" ("2" :: ByteString) - . pair "SignatureMethod" ("HmacSHA256" :: ByteString) - . pair "Timestamp" time - . pair "AWSAccessKeyId" (toBS _authAccess) - $ _rqQuery <> maybe mempty toQuery token - - token = ("SecurityToken" :: ByteString,) . toBS <$> _authToken - - headers = hdr hDate time _rqHeaders - - time = toBS (Time t :: ISO8601) - - svc = serviceOf x diff --git a/src/Network/AWS/Signing/Internal/V4.hs b/src/Network/AWS/Signing/Internal/V4.hs deleted file mode 100644 --- a/src/Network/AWS/Signing/Internal/V4.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - --- Module : Network.AWS.Signing.Internal.V4 --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Signing.Internal.V4 - ( V4 - ) where - -import Control.Applicative -import Control.Lens -import qualified Crypto.Hash.SHA256 as SHA256 -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import qualified Data.Foldable as Fold -import Data.Function hiding ((&)) -import Data.List (groupBy, intersperse, sortBy, sort) -import Data.Maybe -import Data.Monoid -import Data.Ord -import Data.Time -import Network.AWS.Data -import Network.AWS.Request.Internal -import Network.AWS.Signing.Internal -import Network.AWS.Types -import Network.HTTP.Types.Header - -data V4 - -data instance Meta V4 = Meta - { _mAlgorithm :: ByteString - , _mScope :: ByteString - , _mSigned :: ByteString - , _mCReq :: ByteString - , _mSTS :: ByteString - , _mSignature :: ByteString - , _mTime :: UTCTime - } - -instance ToBuilder (Meta V4) where - build Meta{..} = mconcat $ intersperse "\n" - [ "[Version 4 Metadata] {" - , " algorithm = " <> build _mAlgorithm - , " credential scope = " <> build _mScope - , " signed headers = " <> build _mSigned - , " canonical request = {" - , build _mCReq - , " }" - , " string to sign = " <> build _mSTS - , " signature = " <> build _mSignature - , " time = " <> build _mTime - , "}" - ] - -instance AWSPresigner V4 where - presigned a r rq t ex = out & sgRequest - . queryString <>~ auth (out ^. sgMeta) - where - out = finalise qry hash r service a inp t - - qry cs sh = - pair (CI.original hAMZAlgorithm) algorithm - . pair (CI.original hAMZCredential) cs - . pair (CI.original hAMZDate) (Time t :: AWSTime) - . pair (CI.original hAMZExpires) ex - . pair (CI.original hAMZSignedHeaders) sh - . pair (CI.original hAMZToken) (toBS <$> _authToken a) - - inp = rq & rqHeaders .~ [] - - auth = mappend "&X-Amz-Signature=" . _mSignature - - hash = "UNSIGNED-PAYLOAD" - -instance AWSSigner V4 where - signed a r rq t = out & sgRequest - %~ requestHeaders - %~ hdr hAuthorization (authorisation $ out ^. sgMeta) - where - out = finalise (\_ _ -> id) hash r service a inp t - - inp = rq & rqHeaders %~ hdr hAMZDate date . hdrs (maybeToList tok) - - date = toBS (Time t :: AWSTime) - tok = (hAMZToken,) . toBS <$> _authToken a - hash = bodyHash (_rqBody rq) - -authorisation :: Meta V4 -> ByteString -authorisation Meta{..} = BS.concat - [ _mAlgorithm - , " Credential=" - , _mScope - , ", SignedHeaders=" - , _mSigned - , ", Signature=" - , _mSignature - ] - -algorithm :: ByteString -algorithm = "AWS4-HMAC-SHA256" - -finalise :: (ByteString -> ByteString -> Query -> Query) - -> ByteString - -> Region - -> Service (Sv a) - -> AuthEnv - -> Request a - -> UTCTime - -> Signed a V4 -finalise qry hash r s@Service{..} AuthEnv{..} Request{..} t = - Signed meta rq - where - meta = Meta - { _mAlgorithm = algorithm - , _mCReq = canonicalRequest - , _mScope = accessScope - , _mSigned = signedHeaders - , _mSTS = stringToSign - , _mSignature = signature - , _mTime = t - } - - rq = clientRequest - & method .~ meth - & host .~ _endpointHost - & path .~ _rqPath - & queryString .~ BS.cons '?' (toBS query) - & requestHeaders .~ headers - & requestBody .~ _bdyBody _rqBody - - meth = toBS _rqMethod - query = qry accessScope signedHeaders _rqQuery - - Endpoint{..} = endpoint s r - - canonicalQuery = toBS (query & valuesOf %~ Just . fromMaybe "") - - headers = sortBy (comparing fst) (hdr hHost _endpointHost _rqHeaders) - - joinedHeaders = map f $ groupBy ((==) `on` fst) headers - where - f [] = ("", "") - f (h:hs) = (fst h, g (h : hs)) - - g = BS.intercalate "," . sort . map snd - - signedHeaders = mconcat - . intersperse ";" - . map (CI.foldedCase . fst) - $ joinedHeaders - - canonicalHeaders = Fold.foldMap f joinedHeaders - where - f (k, v) = CI.foldedCase k - <> ":" - <> stripBS v - <> "\n" - - canonicalRequest = mconcat $ intersperse "\n" - [ meth - , collapsePath _rqPath - , canonicalQuery - , canonicalHeaders - , signedHeaders - , hash - ] - - scope = - [ toBS (Time t :: BasicTime) - , toBS _endpointScope - , toBS _svcPrefix - , "aws4_request" - ] - - credentialScope = BS.intercalate "/" scope - - accessScope = toBS _authAccess <> "/" <> credentialScope - - signingKey = Fold.foldl1 hmacSHA256 $ ("AWS4" <> toBS _authSecret) : scope - - stringToSign = BS.intercalate "\n" - [ algorithm - , toBS (Time t :: AWSTime) - , credentialScope - , Base16.encode (SHA256.hash canonicalRequest) - ] - - signature = Base16.encode (hmacSHA256 signingKey stringToSign) 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 @@ -1,73 +1,62 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +-- | -- Module : Network.AWS.Types --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay --- Stability : experimental +-- Stability : provisional -- Portability : non-portable (GHC extensions) - +-- module Network.AWS.Types ( -- * Authentication -- ** Credentials - AccessKey (..) - , SecretKey (..) - , SecurityToken (..) + AccessKey (..) + , SecretKey (..) + , SessionToken (..) -- ** Environment - , AuthEnv (..) - , Auth (..) + , AuthEnv (..) + , Auth (..) , withAuth + -- * Logging + , LogLevel (..) + , Logger + -- * Services - , AWSService (..) , Abbrev - , Service (..) + , AWSService (..) + , Service (..) , serviceOf -- * Retries - , Retry (..) - - -- * Endpoints - , Endpoint (..) - , endpoint - - -- * Errors - , ServiceError (..) - , _HttpError - , _SerializerError - , _ServiceError - , _Errors + , Retry (..) -- * Signing - , AWSSigner (..) - , AWSPresigner (..) - , Signed (..) + , AWSSigner (..) + , AWSPresigner (..) , Meta + , Signed (..) , sgMeta , sgRequest -- * Requests - , AWSRequest (..) - , AWSPager (..) - , Request (..) + , AWSRequest (..) + , Request (..) , rqMethod , rqHeaders , rqPath @@ -76,338 +65,439 @@ -- * Responses , Response - , Response' - , Empty (..) - -- * Logging - , LogLevel (..) - , Logger + -- * Errors + , AsError (..) + , Error (..) + -- ** HTTP Errors + , HttpException + -- ** Serialize Errors + , SerializeError (..) + , serializeAbbrev + , serializeStatus + , serializeMessage + -- ** Service Errors + , ServiceError (..) + , serviceAbbrev + , serviceStatus + , serviceHeaders + , serviceCode + , serviceMessage + , serviceRequestId + -- ** Error Types + , ErrorCode (..) + , ErrorMessage (..) + , RequestId (..) -- * Regions - , Region (..) - - -- * Query Actions - , Action (..) + , Endpoint (..) + , Region (..) - -- * Convenience + -- * HTTP , ClientRequest , ClientResponse , ResponseBody , clientRequest + + -- ** Seconds + , Seconds (..) + , _Seconds + , seconds + , microseconds + + -- * Isomorphisms + , _Coerce + , _Default ) where +import Control.Exception +import Control.Exception.Lens (exception) import Control.Applicative import Control.Concurrent (ThreadId) -import Control.Exception (Exception) -import Control.Lens hiding (Action) +import Control.Lens hiding (coerce) import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Aeson hiding (Error) -import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) -import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString.Builder as Build +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.Coerce import Data.Conduit -import Data.Default.Class -import qualified Data.HashSet as Set +import Data.Data (Data, Typeable) import Data.Hashable import Data.IORef -import Data.List (intersperse) import Data.Monoid +import Data.Proxy import Data.String -import Data.Text (Text) import qualified Data.Text.Encoding as Text import Data.Time -import Data.Typeable -import GHC.Generics -import Network.AWS.Data +import GHC.Generics (Generic) +import Network.AWS.Data.Body +import Network.AWS.Data.Crypto +import Network.AWS.Data.Log +import Network.AWS.Data.ByteString +import Network.AWS.Data.Path +import Network.AWS.Data.Query +import Network.AWS.Data.Text +import Network.AWS.Data.XML +import Network.HTTP.Client hiding (Request, Response, Proxy) import qualified Network.HTTP.Client as Client -import Network.HTTP.Client hiding (Request, Response) import Network.HTTP.Types.Header import Network.HTTP.Types.Method import Network.HTTP.Types.Status (Status) +import Text.XML (def) +import Prelude + +-- | A convenience alias to avoid type ambiguity. +type ClientRequest = Client.Request + +-- | A convenience alias encapsulating the common 'Response'. +type ClientResponse = Client.Response ResponseBody + +-- | A convenience alias encapsulating the common 'Response' body. +type ResponseBody = ResumableSource (ResourceT IO) ByteString + +-- | Construct a 'ClientRequest' using common parameters such as TLS and prevent +-- throwing errors when receiving erroneous status codes in respones. +clientRequest :: ClientRequest +clientRequest = def + { Client.secure = True + , Client.port = 443 + , Client.redirectCount = 0 + , Client.checkStatus = \_ _ _ -> Nothing + } + -- | Abbreviated service name. -type Abbrev = Text +newtype Abbrev = Abbrev Text + deriving (Eq, Ord, Show, IsString, FromXML, FromJSON, FromText, ToText, ToLog) --- | An error type representing the subset of errors that can be directly --- attributed to this library. -data ServiceError a - = HttpError HttpException - | SerializerError Abbrev String - | ServiceError Abbrev Status a - | Errors [ServiceError a] +newtype ErrorCode = ErrorCode Text + deriving (Eq, Ord, Show, IsString, FromXML, FromJSON, FromText, ToText, ToLog) + +newtype ErrorMessage = ErrorMessage Text + deriving (Eq, Ord, Show, IsString, FromXML, FromJSON, FromText, ToText, ToLog) + +newtype RequestId = RequestId Text + deriving (Eq, Ord, Show, IsString, FromXML, FromJSON, FromText, ToText, ToLog) + +-- | An error type representing errors that can be attributed to this library. +data Error + = TransportError HttpException + | SerializeError SerializeError + | ServiceError ServiceError deriving (Show, Typeable) -instance (Show a, Typeable a) => Exception (ServiceError a) +instance Exception Error -instance Monoid (ServiceError a) where - mempty = Errors [] - mappend a b = Errors (f a <> f b) - where - f (Errors xs) = xs - f x = [x] +instance ToLog Error where + build = \case + TransportError e -> build e + SerializeError e -> build e + ServiceError e -> build e --- | The properties (such as endpoint) for a service, as well as it's --- associated signing algorithm and error types. -class (AWSSigner (Sg a), Show (Er a)) => AWSService a where - -- | Signing algorithm supported by the service. - type Sg a :: * +data SerializeError = SerializeError' + { _serializeAbbrev :: !Abbrev + , _serializeStatus :: !Status + , _serializeMessage :: String + } deriving (Eq, Show, Typeable) - -- | The general service error. - type Er a :: * +instance ToLog SerializeError where + build SerializeError'{..} = buildLines + [ "[SerializeError] {" + , " service = " <> build _serializeAbbrev + , " status = " <> build _serializeStatus + , " build = " <> build _serializeMessage + , "}" + ] - service :: Service a +serializeAbbrev :: Lens' SerializeError Abbrev +serializeAbbrev = lens _serializeAbbrev (\s a -> s { _serializeAbbrev = a }) -serviceOf :: AWSService (Sv a) => Request a -> Service (Sv a) -serviceOf = const service +serializeStatus :: Lens' SerializeError Status +serializeStatus = lens _serializeStatus (\s a -> s { _serializeStatus = a }) --- | An alias for the common response 'Either' containing a service error in the --- 'Left' case, or the expected response in the 'Right'. -type Response a = Either (ServiceError (Er (Sv a))) (Rs a) +serializeMessage :: Lens' SerializeError String +serializeMessage = lens _serializeMessage (\s a -> s { _serializeMessage = a }) -type Response' a = Either (ServiceError (Er (Sv a))) (Status, Rs a) +data ServiceError = ServiceError' + { _serviceAbbrev :: !Abbrev + , _serviceStatus :: !Status + , _serviceHeaders :: [Header] + , _serviceCode :: !ErrorCode + , _serviceMessage :: Maybe ErrorMessage + , _serviceRequestId :: Maybe RequestId + } deriving (Eq, Show, Typeable) +instance ToLog ServiceError where + build ServiceError'{..} = buildLines + [ "[ServiceError] {" + , " service = " <> build _serviceAbbrev + , " status = " <> build _serviceStatus + , " code = " <> build _serviceCode + , " build = " <> build _serviceMessage + , " request-id = " <> build _serviceRequestId + , "}" + ] + +serviceAbbrev :: Lens' ServiceError Abbrev +serviceAbbrev = lens _serviceAbbrev (\s a -> s { _serviceAbbrev = a }) + +serviceStatus :: Lens' ServiceError Status +serviceStatus = lens _serviceStatus (\s a -> s { _serviceStatus = a }) + +serviceHeaders :: Lens' ServiceError [Header] +serviceHeaders = lens _serviceHeaders (\s a -> s { _serviceHeaders = a }) + +serviceCode :: Lens' ServiceError ErrorCode +serviceCode = lens _serviceCode (\s a -> s { _serviceCode = a }) + +serviceMessage :: Lens' ServiceError (Maybe ErrorMessage) +serviceMessage = lens _serviceMessage (\s a -> s { _serviceMessage = a }) + +serviceRequestId :: Lens' ServiceError (Maybe RequestId) +serviceRequestId = lens _serviceRequestId (\s a -> s { _serviceRequestId = a }) + +class AsError a where + -- | A general Amazonka error. + _Error :: Prism' a Error + {-# MINIMAL _Error #-} + + -- | An error occured while communicating over HTTP with a remote service. + _TransportError :: Prism' a HttpException + + -- | A serialisation error occured when attempting to deserialise a response. + _SerializeError :: Prism' a SerializeError + + -- | A service specific error returned by the remote service. + _ServiceError :: Prism' a ServiceError + + _TransportError = _Error . _TransportError + _SerializeError = _Error . _SerializeError + _ServiceError = _Error . _ServiceError + +instance AsError SomeException where + _Error = exception + +instance AsError Error where + _Error = id + + _TransportError = prism TransportError $ \case + TransportError e -> Right e + x -> Left x + + _SerializeError = prism SerializeError $ \case + SerializeError e -> Right e + x -> Left x + + _ServiceError = prism ServiceError $ \case + ServiceError e -> Right e + x -> Left x + +data Endpoint = Endpoint + { _endpointHost :: ByteString + , _endpointScope :: ByteString + } deriving (Eq, Show, Data, Typeable) + data LogLevel - = Info -- ^ Informational messages supplied by the user, not used by the library. - | Debug -- ^ Info level + debug messages + non-streaming response bodies. - | Trace -- ^ Debug level + potentially sensitive signing metadata. + = Error -- ^ Error messages only. + | Info -- ^ Info messages supplied by the user - this level is not emitted by the library. + | Debug -- ^ Useful debug information + info + error levels. + | Trace -- ^ Includes potentially sensitive signing metadata, and non-streaming response bodies. deriving (Eq, Ord, Enum, Show) +-- | A function threaded through various request and serialisation routines +-- to log informational and debug messages. type Logger = LogLevel -> Builder -> IO () --- | Specify how a request can be de/serialised. -class (AWSService (Sv a), AWSSigner (Sg (Sv a))) => AWSRequest a where - -- | The service definition for a request. - type Sv a :: * +-- | Constants and predicates used to create a 'RetryPolicy'. +data Retry = Exponential + { _retryBase :: !Double + , _retryGrowth :: !Int + , _retryAttempts :: !Int + , _retryCheck :: ServiceError -> Maybe Text + -- ^ Returns a descriptive name for logging + -- if the request should be retried. + } - -- | The successful, expected response associated with a request. - type Rs a :: * +-- | Attributes and functions specific to an AWS service. +data Service s = Service + { _svcAbbrev :: !Abbrev + , _svcPrefix :: ByteString + , _svcVersion :: ByteString + , _svcEndpoint :: Region -> Endpoint + , _svcTimeout :: Maybe Seconds + , _svcStatus :: Status -> Bool + , _svcError :: Abbrev -> Status -> [Header] -> LazyByteString -> Error + , _svcRetry :: Retry + } - request :: a -> Request a - response :: MonadResource m - => Logger - -> Request a - -> Either HttpException ClientResponse - -> m (Response' a) +-- | An unsigned request. +data Request a = Request + { _rqMethod :: !StdMethod + , _rqPath :: !RawPath + , _rqQuery :: !QueryString + , _rqHeaders :: ![Header] + , _rqBody :: !RqBody + } --- | Specify how an 'AWSRequest' and it's associated 'Rs' response can generate --- a subsequent request, if available. -class AWSRequest a => AWSPager a where - page :: a -> Rs a -> Maybe a +instance Show (Request a) where + show = LBS8.unpack . Build.toLazyByteString . build +instance ToLog (Request a) where + build Request{..} = buildLines + [ "[Raw Request] {" + , " method = " <> build _rqMethod + , " path = " <> build (escapePath _rqPath) + , " query = " <> build _rqQuery + , " headers = " <> build _rqHeaders + , " body = {" + , " hash = " <> build (digestToBase Base16 (bodySHA256 _rqBody)) + , " payload =\n" <> build (bodyRequest _rqBody) + , " }" + , "}" + ] + +rqBody :: Lens' (Request a) RqBody +rqBody = lens _rqBody (\s a -> s { _rqBody = a }) + +rqHeaders :: Lens' (Request a) [Header] +rqHeaders = lens _rqHeaders (\s a -> s { _rqHeaders = a }) + +rqMethod :: Lens' (Request a) StdMethod +rqMethod = lens _rqMethod (\s a -> s { _rqMethod = a }) + +rqPath :: Lens' (Request a) RawPath +rqPath = lens _rqPath (\s a -> s { _rqPath = a }) + +rqQuery :: Lens' (Request a) QueryString +rqQuery = lens _rqQuery (\s a -> s { _rqQuery = a }) + +class AWSSigner v where + signed :: v ~ Sg s + => AuthEnv + -> Region + -> UTCTime + -> Service s + -> Request a + -> Signed v a + +class AWSPresigner v where + presigned :: v ~ Sg s + => AuthEnv + -> Region + -> UTCTime + -> Seconds + -> Service s + -> Request a + -> Signed v a + -- | Signing metadata data specific to a signing algorithm. -- --- /Note:/ this is used for test and debug purposes, or is otherwise ignored. +-- /Note:/ this is used for logging purposes, and is otherwise ignored. data family Meta v :: * -- | A signed 'ClientRequest' and associated metadata specific to the signing -- algorithm that was used. -data Signed a v where - Signed :: ToBuilder (Meta v) +data Signed v a where + Signed :: ToLog (Meta v) => { _sgMeta :: Meta v , _sgRequest :: ClientRequest } - -> Signed a v + -> Signed v a -sgMeta :: Lens' (Signed a v) (Meta v) +sgMeta :: ToLog (Meta v) => Lens' (Signed v a) (Meta v) sgMeta f (Signed m rq) = f m <&> \y -> Signed y rq -sgRequest :: Lens' (Signed a v) ClientRequest +-- Lens' specifically since 'a' cannot be substituted. +sgRequest :: Lens' (Signed v a) ClientRequest sgRequest f (Signed m rq) = f rq <&> \y -> Signed m y -class AWSSigner v where - signed :: (AWSService (Sv a), v ~ Sg (Sv a)) - => AuthEnv - -> Region - -> Request a - -> UTCTime - -> Signed a v +class AWSSigner (Sg a) => AWSService a where + -- | The default signing algorithm for the service. + type Sg a :: * -class AWSPresigner v where - presigned :: (AWSService (Sv a), v ~ Sg (Sv a)) - => AuthEnv - -> Region - -> Request a - -> UTCTime - -> Integer - -> Signed a v + service :: Sv p ~ a => Proxy p -> Service a +serviceOf :: forall a. AWSService (Sv a) => a -> Service (Sv a) +serviceOf = const $ service (Proxy :: Proxy a) + +type Response a = (Status, Rs a) + +-- | Specify how a request can be de/serialised. +class AWSService (Sv a) => AWSRequest a where + -- | The successful, expected response associated with a request. + type Rs a :: * + + -- | The default sevice configuration for the request. + type Sv a :: * + + request :: a -> Request a + response :: MonadResource m + => Logger + -> Service s + -> Request a + -> ClientResponse + -> m (Response a) + -- | Access key credential. newtype AccessKey = AccessKey ByteString - deriving (Eq, Show, IsString, ToText, ToByteString, ToBuilder) + deriving (Eq, Show, IsString, ToText, ToByteString, ToLog) -- | Secret key credential. newtype SecretKey = SecretKey ByteString deriving (Eq, IsString, ToText, ToByteString) --- | A security token used by STS to temporarily authorise access to +-- | A session token used by STS to temporarily authorise access to -- an AWS resource. -newtype SecurityToken = SecurityToken ByteString +newtype SessionToken = SessionToken ByteString deriving (Eq, IsString, ToText, ToByteString) -- | The authorisation environment. data AuthEnv = AuthEnv { _authAccess :: !AccessKey , _authSecret :: !SecretKey - , _authToken :: Maybe SecurityToken + , _authToken :: Maybe SessionToken , _authExpiry :: Maybe UTCTime } +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 + , "}" + ] + 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 SecurityToken) (o .:? "Token") + <*> fmap (f SessionToken) (o .:? "Token") <*> o .:? "Expiration" where f g = fmap (g . Text.encodeUtf8) -instance ToBuilder AuthEnv where - build AuthEnv{..} = mconcat $ intersperse "\n" - [ "[Amazonka Auth] {" - , " access key = " <> build _authAccess - , " secret key = ****" - , " security token = " <> maybe "Nothing" (const "Just ****") _authToken - , " expiry = " <> build _authExpiry - , "}" - ] - -- | An authorisation environment containing AWS credentials, and potentially -- a reference which can be refreshed out-of-band as temporary credentials expire. data Auth = Ref ThreadId (IORef AuthEnv) | Auth AuthEnv -instance ToBuilder Auth where +instance ToLog Auth where build (Ref t _) = "[Amazonka Auth] { build (show t) <> "> }" build (Auth e) = build e withAuth :: MonadIO m => Auth -> (AuthEnv -> m a) -> m a -withAuth (Auth e) f = f e withAuth (Ref _ r) f = liftIO (readIORef r) >>= f - -data Endpoint = Endpoint - { _endpointHost :: ByteString - , _endpointScope :: ByteString - } deriving (Eq, Show) - --- | Determine the full host address and credential scope for a 'Service' within --- the specified 'Region'. -endpoint :: Service a -> Region -> Endpoint -endpoint Service{..} r = go (CI.mk _svcPrefix) - where - go = \case - "iam" - | china -> region "iam.cn-north-1.amazonaws.com.cn" - | govcloud -> region "iam.us-gov.amazonaws.com" - | otherwise -> global "iam.amazonaws.com" - - "sdb" - | virginia -> region "sdb.amazonaws.com" - - "sts" - | china -> region "sts.cn-north-1.amazonaws.com.cn" - | govcloud -> region ("sts." <> reg <> ".amazonaws.com") - | otherwise -> global "sts.amazonaws.com" - - "s3" - | virginia -> global "s3.amazonaws.com" - | china -> region ("s3." <> reg <> ".amazonaws.com.cn") - | s3 -> region ("s3-" <> reg <> ".amazonaws.com") - - "rds" - | virginia -> global "rds.amazonaws.com" - - "route53" - | not china -> global "route53.amazonaws.com" - - "emr" - | virginia -> global "elasticmapreduce.us-east-1.amazonaws.com" - | otherwise -> region (reg <> ".elasticmapreduce.amazonaws.com") - - "sqs" - | virginia -> global "queue.amazonaws.com" - | china -> region (reg <> ".queue.amazonaws.com.cn") - - "importexport" - | not china -> region "importexport.amazonaws.com" - - "cloudfront" - | not china -> global "cloudfront.amazonaws.com" - - _ | china -> region (_svcPrefix <> "." <> reg <> ".amazonaws.com.cn") - | otherwise -> region (_svcPrefix <> "." <> reg <> ".amazonaws.com") - - virginia = r == NorthVirginia - - s3 = r `Set.member` except - - govcloud = "us-gov" `BS.isPrefixOf` reg - china = "cn-" `BS.isPrefixOf` reg - - region h = Endpoint { _endpointHost = h, _endpointScope = reg } - global h = Endpoint { _endpointHost = h, _endpointScope = "us-east-1" } - - reg = toBS r - - except = Set.fromList - [ GovCloud - , GovCloudFIPS - , Ireland - , NorthCalifornia - , NorthVirginia - , Oregon - , SaoPaulo - , Singapore - , Sydney - , Tokyo - ] - --- | Attributes specific to an AWS service. -data Service a = Service - { _svcAbbrev :: !Text - , _svcPrefix :: !ByteString - , _svcVersion :: !ByteString - , _svcTargetPrefix :: Maybe ByteString - , _svcJSONVersion :: Maybe ByteString - , _svcHandle :: Status -> Maybe (LazyByteString -> ServiceError (Er a)) - , _svcRetry :: Retry a - } - --- | Constants and predicates used to create a 'RetryPolicy'. -data Retry a = Exponential - { _retryBase :: !Double - , _retryGrowth :: !Int - , _retryAttempts :: !Int - , _retryCheck :: Status -> Er a -> Bool - } - --- | An unsigned request. -data Request a = Request - { _rqMethod :: !StdMethod - , _rqPath :: !ByteString - , _rqQuery :: Query - , _rqHeaders :: [Header] - , _rqBody :: RqBody - } - -instance Default (Request a) where - def = Request GET "/" mempty mempty "" - -instance ToBuilder (Request a) where - build Request{..} = mconcat $ intersperse "\n" - [ "[Raw Request] {" - , " method = " <> build _rqMethod - , " path = " <> build _rqPath - , " query = " <> build _rqQuery - , " headers = " <> build _rqHeaders - , " body = {" - , " hash = " <> build (bodyHash _rqBody) - , " payload =\n" <> build (_bdyBody _rqBody) - , " }" - , "}" - ] +withAuth (Auth e) f = f e -- | The sum of available AWS regions. data Region @@ -423,13 +513,10 @@ | GovCloud -- ^ AWS GovCloud / us-gov-west-1 | GovCloudFIPS -- ^ AWS GovCloud (FIPS 140-2) S3 Only / fips-us-gov-west-1 | SaoPaulo -- ^ South America / sa-east-1 - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) instance Hashable Region -instance Default Region where - def = NorthVirginia - instance FromText Region where parser = takeLowerText >>= \case "eu-west-1" -> pure Ireland @@ -463,38 +550,52 @@ SaoPaulo -> "sa-east-1" instance ToByteString Region -instance ToBuilder Region +instance ToLog Region where + build = build . toBS + instance FromXML Region where parseXML = parseXMLText "Region" instance ToXML Region where toXML = toXMLText --- | A service's query action. -newtype Action = Action Text - deriving (Eq, Ord, Show, IsString, ToText, ToByteString) - -data Empty = Empty - deriving (Eq, Show) +-- | An integral value representing seconds. +newtype Seconds = Seconds Int + deriving + ( Eq + , Ord + , Read + , Show + , Enum + , Num + , Bounded + , Integral + , Real + , Data + , Typeable + , Generic + , ToQuery + , ToByteString + , ToText + ) -instance ToJSON Empty where - toJSON = const Null +_Seconds :: Iso' Seconds Int +_Seconds = iso seconds Seconds --- | A convenience alias to avoid type ambiguity. -type ClientRequest = Client.Request +instance ToLog Seconds where + build (Seconds n) = build n <> "s" --- | A convenience alias encapsulating the common 'Response'. -type ClientResponse = Client.Response ResponseBody +seconds :: Seconds -> Int +seconds (Seconds n) = n --- | A convenience alias encapsulating the common 'Response' body. -type ResponseBody = ResumableSource (ResourceT IO) ByteString +microseconds :: Seconds -> Int +microseconds (Seconds n) = n * 1000000 --- | Construct a 'ClientRequest' using common parameters such as TLS and prevent --- throwing errors when receiving erroneous status codes in respones. -clientRequest :: ClientRequest -clientRequest = def - { Client.secure = True - , Client.port = 443 - , Client.checkStatus = \_ _ _ -> Nothing - } +_Coerce :: (Coercible a b, Coercible b a) => Iso' a b +_Coerce = iso coerce coerce -makePrisms ''ServiceError -makeLenses ''Request +-- | Invalid Iso, should be a Prism but exists for ease of composition +-- with the current 'Lens . Iso' chaining to hide internal types from the user. +_Default :: Monoid a => Iso' (Maybe a) a +_Default = iso f Just + where + f (Just x) = x + f Nothing = mempty diff --git a/src/Network/AWS/Waiter.hs b/src/Network/AWS/Waiter.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Waiter.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.AWS.Waiter +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Waiter + ( + -- * Types + Acceptor + , Accept (..) + , Wait (..) + + -- * Acceptors + , accept + + -- * Matchers + , matchAll + , matchAny + , matchError + , matchStatus + + -- * Util + , nonEmpty + ) where + +import Control.Applicative +import Control.Lens +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.Types + +import Prelude + +type Acceptor a = Request a -> Either Error (Response a) -> Maybe Accept + +data Accept + = AcceptSuccess + | AcceptFailure + | AcceptRetry + deriving (Eq, Show) + +instance ToLog Accept where + build = \case + AcceptSuccess -> "Success" + AcceptFailure -> "Failure" + AcceptRetry -> "Retry" + +-- | Timing and acceptance criteria to check fulfillment of a remote operation. +data Wait a = Wait + { _waitName :: ByteString + , _waitAttempts :: !Int + , _waitDelay :: !Seconds + , _waitAcceptors :: [Acceptor a] + } + +accept :: Wait a -> Acceptor a +accept w rq rs = listToMaybe . mapMaybe (\f -> f rq rs) $ _waitAcceptors w + +matchAll :: Eq b => b -> Accept -> Fold (Rs a) b -> Acceptor a +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 + +matchStatus :: Int -> Accept -> Acceptor a +matchStatus x a _ = \case + Right (s, _) | x == fromEnum s -> Just a + Left e | Just x == (fromEnum <$> e ^? httpStatus) -> Just a + _ -> Nothing + +matchError :: ErrorCode -> Accept -> Acceptor a +matchError c a _ = \case + Left e | Just c == e ^? _ServiceError . serviceCode -> Just a + _ -> Nothing + +match :: (Rs a -> Bool) -> Accept -> Acceptor a +match f a _ = \case + Right (_, rs) | f rs -> Just a + _ -> Nothing + +nonEmpty :: Fold a Text -> Fold a Bool +nonEmpty l = l . to Text.null diff --git a/src/Network/AWS/Waiters.hs b/src/Network/AWS/Waiters.hs deleted file mode 100644 --- a/src/Network/AWS/Waiters.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - --- Module : Network.AWS.Waiters --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Network.AWS.Waiters - ( - -- * Types - Acceptor - , Accept (..) - , Wait (..) - - -- * Acceptors - , accept - - -- * Matchers - , matchAll - , matchAny - , matchError - , matchStatus - - -- * Util - , nonEmpty - - -- * Lenses - , module Control.Lens - ) where - -import Control.Lens -import Data.ByteString (ByteString) -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import Network.AWS.Data -import Network.AWS.Error -import Network.AWS.Types -import Network.HTTP.Types - -type Acceptor a = Request a -> Response' a -> Maybe Accept - -data Accept - = AcceptSuccess - | AcceptFailure - | AcceptRetry - deriving (Eq, Show) - -instance ToBuilder Accept where - build = \case - AcceptSuccess -> "Success" - AcceptFailure -> "Failure" - AcceptRetry -> "Retry" - --- | Timing and acceptance criteria to check fulfillment of a remote operation. -data Wait a = Wait - { _waitName :: !ByteString - , _waitAttempts :: !Int - , _waitDelay :: !Int - , _waitAcceptors :: [Acceptor a] - } - -accept :: Wait a -> Acceptor a -accept w rq rs = listToMaybe . mapMaybe (\f -> f rq rs) $ _waitAcceptors w - -matchAll :: Eq b => b -> Accept -> Fold (Rs a) b -> Acceptor a -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 - -matchStatus :: Int -> Accept -> Acceptor a -matchStatus x a _ = \case - Left (ServiceError _ s _) - | x == statusCode s -> Just a - Right (s, _) - | x == statusCode s -> Just a - _ -> Nothing - -matchError :: AWSErrorCode (Er (Sv a)) => ErrorCode -> Accept -> Acceptor a -matchError c a _ = \case - Left (ServiceError _ _ e) - | Just c == awsErrorCode e -> Just a - _ -> Nothing - -match :: (Rs a -> Bool) -> Accept -> Acceptor a -match f a _ = \case - Right (_, rs) - | f rs -> Just a - _ -> Nothing - -nonEmpty :: Fold a Text -> Fold a Bool -nonEmpty l = l . to Text.null diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,19 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | -- Module : Main --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) - +-- module Main (main) where -import qualified Test.AWS.Data as Data +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.Time as Time +import qualified Test.AWS.Sign.V4 as V4 import Test.Tasty main :: IO () -main = defaultMain $ testGroup "amazonka" - [ Data.tests - ] +main = defaultMain $ + testGroup "amazonka-core" + [ testGroup "primitives" + [ Numeric.tests + , Time.tests + , Base64.tests + , Maybe.tests + ] + + , testGroup "collections" + [ List.tests + ] + + , testGroup "signing" + [ V4.tests + ] + ] diff --git a/test/Test/AWS/Arbitrary.hs b/test/Test/AWS/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Test/AWS/Arbitrary.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Test.AWS.Arbitrary +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +module Test.AWS.Arbitrary where + +import qualified Data.ByteString.Char8 as BS8 +import Data.CaseInsensitive (CI, FoldCase) +import qualified Data.CaseInsensitive as CI +import Data.String +import qualified Data.Text as Text +import Data.Time +import Network.AWS.Data.Query +import Network.AWS.Prelude +import Network.HTTP.Types +import Test.QuickCheck.Gen as QC +import qualified Test.QuickCheck.Unicode as Unicode +import Test.Tasty.QuickCheck + +instance Arbitrary (Request ()) where + arbitrary = Request + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Abbrev where + arbitrary = fromString <$> QC.elements + [ "IAM" + , "SDB" + , "STS" + , "S3" + , "EC2" + , "RDS" + , "EMR" + , "SQS" + , "SNS" + , "ImportExport" + , "CloudFront" + , "SES" + , "Route53" + ] + +instance Arbitrary StdMethod where + arbitrary = QC.elements + [ GET + , POST + , HEAD + , PUT + , DELETE + , TRACE + , CONNECT + , OPTIONS + , PATCH + ] + +instance Arbitrary Region where + arbitrary = QC.elements + [ Ireland + , Frankfurt + , Tokyo + , Singapore + , Sydney + , Beijing + , NorthVirginia + , NorthCalifornia + , Oregon + , GovCloud + , GovCloudFIPS + , SaoPaulo + ] + +instance Arbitrary RqBody where + arbitrary = toBody <$> (arbitrary :: Gen ByteString) + +instance Arbitrary RawPath where + arbitrary = do + xs <- listOf (BS8.pack . getNonEmpty <$> arbitrary) + return $! rawPath (BS8.intercalate "/" xs) + +instance Arbitrary QueryString where + arbitrary = oneof + [ QList <$> arbitrary + , QPair <$> arbitrary <*> arbitrary + , QValue <$> arbitrary + ] + +instance (Arbitrary a, FoldCase a) => Arbitrary (CI a) where + arbitrary = CI.mk <$> arbitrary + +instance Arbitrary Text where + arbitrary = Text.pack <$> suchThat Unicode.string (not . null) + +instance Arbitrary ByteString where + arbitrary = BS8.pack <$> suchThat Unicode.string (not . null) + +instance Arbitrary DiffTime where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +instance Arbitrary UTCTime where + arbitrary = UTCTime + <$> arbitrary + <*> (fromRational . toRational <$> choose (0 :: Double, 86400)) + + shrink u@(UTCTime day dayTime) = + [ u { utctDay = d } | d <- shrink day ] + ++ [ u { utctDayTime = t } | t <- shrink dayTime ] + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay <$> (2000 +) <$> arbitrary + shrink = fmap ModifiedJulianDay . shrink . toModifiedJulianDay diff --git a/test/Test/AWS/Data.hs b/test/Test/AWS/Data.hs deleted file mode 100644 --- a/test/Test/AWS/Data.hs +++ /dev/null @@ -1,25 +0,0 @@ --- Module : Test.AWS.Data --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Test.AWS.Data (tests) where - -import qualified Test.AWS.Data.List as List -import qualified Test.AWS.Data.Map as Map -import qualified Test.AWS.Data.Numeric as Numeric -import qualified Test.AWS.Data.Time as Time -import Test.Tasty - -tests :: TestTree -tests = testGroup "data types" - [ List.tests - , Map.tests - , Numeric.tests - , Time.tests - ] diff --git a/test/Test/AWS/Data/Base64.hs b/test/Test/AWS/Data/Base64.hs new file mode 100644 --- /dev/null +++ b/test/Test/AWS/Data/Base64.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Test.AWS.Data.Base64 +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +module Test.AWS.Data.Base64 (tests) where + +import Data.Monoid +import Data.String +import Network.AWS.Prelude +import Network.HTTP.Types +import Test.AWS.Util +import Test.Tasty + +tests :: TestTree +tests = testGroup "base64" + [ testGroup "text" + [ testFromText "deserialise" encoded decoded + , testToText "serialise" encoded decoded + ] + + , testGroup "query" + [ testToQuery "serialise" ("x=" <> urlEncode True encoded) decoded + ] + + , testGroup "xml" + [ testFromXML "deserialise" encoded decoded + , testToXML "serialise" encoded decoded + ] + + , testGroup "json" + [ testFromJSON "deserialise" (str encoded) decoded + , testToJSON "serialise" (str encoded) decoded + ] + ] + +encoded :: IsString a => a +encoded = "U2VkIHV0IHBlcnNwaWNpYXRpcyB1bmRlIG9tbmlzIGlzdGUgbmF0dXMgZXJyb3Igc2l0IHZvbHVwdGF0ZW0=" + +decoded :: Base64 +decoded = Base64 "Sed ut perspiciatis unde omnis iste natus error sit voluptatem" 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 @@ -1,99 +1,176 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +-- | -- Module : Test.AWS.Data.List --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) - +-- module Test.AWS.Data.List (tests) where -import Network.AWS.Prelude -import Test.AWS.TH -import Test.AWS.Types -import Test.Tasty -import Test.Tasty.HUnit +import Network.AWS.Prelude +import Test.AWS.Util +import Test.Tasty tests :: TestTree tests = testGroup "list" - [ testGroup "deserialise xml" - [ testCase "entries" $ - assertXML unflattened (Entries items) - , testCase "flattened" $ - assertXML flattened items + [ testGroup "query" + [ testGroup "serialise" + [ testGroup "non-flattened" + [ testToQuery "absent" + "x.name=absent" + (NonFlat "absent" absent) + + , testToQuery "primitive" + "x.itemSet.item.1=1&x.itemSet.item.2=2&x.itemSet.item.3=3&x.name=primitive" + (NonFlat "primitive" (Just ([1, 2, 3] :: [Int]))) + + , testToQuery "complex" + "x.itemSet.item.1.value=1&x.itemSet.item.2.value=2&x.name=complex" + (NonFlat "complex" (Just [Item 1, Item 2])) + ] + + , testGroup "flattened" + [ testToQuery "absent/empty" + "x.name=empty" + (Flat "empty" empty) + + , testToQuery "primitive" + "x.item.1=4&x.item.2=5&x.item.3=6&x.name=primitive" + (Flat "primitive" (Just ([4, 5, 6] :: [Int]))) + + , testToQuery "complex" + "x.item.1.value=9&x.item.2.value=10&x.name=complex" + (Flat "complex" (Just [Item 9, Item 10])) + ] + ] ] - ] -data Item = Item - { itemText :: Text - , itemDate :: Text - , itemInt :: Int - } deriving (Eq, Show) + , testGroup "xml" + [ testGroup "deserialise" + [ testGroup "non-flattened" + [ testFromXML "absent" + "absent" + (NonFlat "absent" absent) -instance FromXML Item where - parseXML x = Item - <$> x .@ "Text" - <*> x .@ "Date" - <*> x .@ "Int" + , testFromXML "empty" + "empty" + (NonFlat "empty" absent) -items :: List "Item" Item -items = List - [ Item - { itemText = "828ef3fdfa96f00ad9f27c383fc9ac7" - , itemDate = "2006-01-01T12:00:00.000Z" - , itemInt = 5 - } - , Item - { itemText = "fe3f123jfa96f00ad9f27c383fc9sd1" - , itemDate = "2014-11-02T01:20:12" - , itemInt = 123 - } + , testFromXML "primitive" + "primitive123" + (NonFlat "primitive" (Just ([1, 2, 3] :: [Int]))) + + , testFromXML "complex" + "complex12" + (NonFlat "complex" (Just [Item 1, Item 2])) + ] + + , testGroup "flattened" + [ testFromXML "absent/empty" + "empty" + (Flat "empty" empty) + + , testFromXML "primitive" + "primitive456" + (Flat "primitive" (Just ([4, 5, 6] :: [Int]))) + + , testFromXML "complex" + "complex910" + (Flat "complex" (Just [Item 9, Item 10])) + ] + ] + + , testGroup "serialise" + [ testGroup "non-flattened" + [ testToXML "absent" + "absent" + (NonFlat "absent" absent) + + , testToXML "primitive" + "primitive123" + (NonFlat "primitive" (Just ([1, 2, 3] :: [Int]))) + + , testToXML "complex" + "complex12" + (NonFlat "complex" (Just [Item 1, Item 2])) + ] + + , testGroup "flattened" + [ testToXML "absent/empty" + "empty" + (Flat "empty" empty) + + , testToXML "primitive" + "primitive456" + (Flat "primitive" (Just ([4, 5, 6] :: [Int]))) + + , testToXML "complex" + "complex910" + (Flat "complex" (Just [Item 9, Item 10])) + ] + ] + ] ] -unflattened :: LazyByteString -unflattened = [doc| - - - foo - N - Ned - - - 2006-01-01T12:00:00.000Z - 828ef3fdfa96f00ad9f27c383fc9ac7 - 5 - - - 2014-11-02T01:20:12 - fe3f123jfa96f00ad9f27c383fc9sd1 - 123 - - - - |] +empty :: Maybe [Int] +empty = Just [] -flattened :: LazyByteString -flattened = [doc| - - - foo - N - Ned - - 2006-01-01T12:00:00.000Z - 828ef3fdfa96f00ad9f27c383fc9ac7 - 5 - - - 2014-11-02T01:20:12 - fe3f123jfa96f00ad9f27c383fc9sd1 - 123 - - - |] +absent :: Maybe [Int] +absent = Nothing + +data NonFlat a = NonFlat Text (Maybe [a]) + deriving (Eq, Show) + +instance ToQuery a => ToQuery (NonFlat a) where + toQuery (NonFlat n x) = mconcat + [ "name" =: n + , "itemSet" =: toQuery (toQueryList "item" <$> x) + ] + +instance FromXML a => FromXML (NonFlat a) where + parseXML x = NonFlat + <$> x .@ "name" + <*> (x .@? "itemSet" + .!@ mempty + >>= may (parseXMLList "item")) + +instance ToXML a => ToXML (NonFlat a) where + toXML (NonFlat n x) = mconcat + [ "name" @= n + , "itemSet" @= toXML (toXMLList "item" <$> x) + ] + +data Flat a = Flat Text (Maybe [a]) + deriving (Eq, Show) + +instance ToQuery a => ToQuery (Flat a) where + toQuery (Flat n x) = mconcat + [ "name" =: n + , toQuery (toQueryList "item" <$> x) + ] + +instance FromXML a => FromXML (Flat a) where + parseXML x = Flat + <$> x .@ "name" + <*> may (parseXMLList "item") x + +instance ToXML a => ToXML (Flat a) where + toXML (Flat n x) = mconcat + [ "name" @= n + , toXML (toXMLList "item" <$> x) + ] + +newtype Item = Item Int + deriving (Eq, Show) + +instance ToQuery Item where + toQuery (Item n) = "value" =: n + +instance FromXML Item where + parseXML x = Item <$> x .@ "value" + +instance ToXML Item where + toXML (Item n) = "value" @= n diff --git a/test/Test/AWS/Data/Map.hs b/test/Test/AWS/Data/Map.hs deleted file mode 100644 --- a/test/Test/AWS/Data/Map.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - --- Module : Test.AWS.Data.Map --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Test.AWS.Data.Map (tests) where - -import GHC.Exts -import Network.AWS.Prelude -import Test.AWS.TH -import Test.AWS.Types -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "map" - [ testGroup "deserialise xml" - [ testCase "entries" $ - assertXML unflattened (Entries entries) - , testCase "flattened" $ - assertXML flattened entries - ] - ] - -entries :: EMap "entry" "key" "value" Text Text -entries = fromList - [ ("foo", "828ef3fdfa96f00ad9f27c383fc9ac7") - , ("bar", "fe3f123jfa96f00ad9f27c383fc9sd1") - , ("baz", "e50e9ce187d0a3a62f2ac0a5d89bf0a") - ] - -unflattened :: LazyByteString -unflattened = [doc| - - - N - - - baz - e50e9ce187d0a3a62f2ac0a5d89bf0a - - - foo - 828ef3fdfa96f00ad9f27c383fc9ac7 - - - bar - fe3f123jfa96f00ad9f27c383fc9sd1 - - - test - - |] - -flattened :: LazyByteString -flattened = [doc| - - - foo - N - - foo - 828ef3fdfa96f00ad9f27c383fc9ac7 - - - bar - fe3f123jfa96f00ad9f27c383fc9sd1 - - - baz - e50e9ce187d0a3a62f2ac0a5d89bf0a - - Ned - - |] diff --git a/test/Test/AWS/Data/Maybe.hs b/test/Test/AWS/Data/Maybe.hs new file mode 100644 --- /dev/null +++ b/test/Test/AWS/Data/Maybe.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Test.AWS.Data.Maybe +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +module Test.AWS.Data.Maybe (tests) where + +import Network.AWS.Prelude +import Test.AWS.Util +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "maybe" + [ testGroup "xml" + [ testGroup "serialise" + [ testCase "nothing" $ + wrapXML "foo" + @?= encodeXML (X (Item "foo" Nothing)) + + , testCase "just" $ + wrapXML "bar23" + @?= encodeXML (X (Item "bar" (Just 23))) + ] + ] + ] + +data Item = Item Text (Maybe Int) + deriving (Eq, Show) + +instance ToXML Item where + toXML (Item x y) = mconcat + [ "Key" @= x + , "Num" @= y + ] 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 @@ -1,103 +1,128 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | -- Module : Test.AWS.Data.Numeric --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) - +-- module Test.AWS.Data.Numeric (tests) where -import Data.Aeson -import Network.AWS.Prelude -import Test.Tasty -import Test.Tasty.HUnit +import Control.Applicative +import Network.AWS.Prelude +import Test.AWS.Util +import Test.Tasty tests :: TestTree tests = testGroup "numeric" - [ testGroup "JSON serialization" - [ testEncode encodeItems - , testDecode decodeItems - ] - ] + [ testGroup "json" + [ testGroup "deserialisation" + [ testFromJSON "natural" + "123" (Nat 123) --- With a basic record, checks several serialization edge cases --- between String, Int, and Nat values for numbers. -data Item = Item - { itemNat :: Maybe Nat - , itemInt :: Maybe Int - , itemStr :: Maybe String - } deriving (Eq, Show) + , testFromJSON "int" + (toLazyBS maxInt) maxInt -instance ToJSON Item where - toJSON Item{..} = object - [ "item_nat" .= itemNat - , "item_int" .= itemInt - , "item_str" .= itemStr + , testFromJSON "negative int" + (toLazyBS minInt) minInt + + , testFromJSON "integer" + "891324" (891324 :: Integer) + + , testFromJSON "negative integer" + "-998" (-998 :: Integer) + + , testFromJSON "double" + "46.39212" (46.39212 :: Double) + + , testFromJSON "negative double" + "-1.09231" (-1.09231 :: Double) + + , testFromJSON "numeric text" + "\"22\"" ("22" :: Text) + ] + + , testGroup "serialisation" + [ testToJSON "natural" + "123" (Nat 123) + + , testToJSON "int" + (toLazyBS maxInt) maxInt + + , testToJSON "negative int" + (toLazyBS minInt) minInt + + , testToJSON "integer" + "891324" (891324 :: Integer) + + , testToJSON "negative integer" + "-998" (-998 :: Integer) + + , testToJSON "double" + "46.39212" (46.39212 :: Double) + + , testToJSON "negative double" + "-1.09231" (-1.09231 :: Double) + + , testToJSON "numeric string" + "\"22\"" ("22" :: String) + ] ] -instance FromJSON Item where - parseJSON = withObject "Item" $ \o -> Item - <$> o .:? "item_nat" - <*> o .:? "item_int" - <*> o .:? "item_str" + , testGroup "xml" + [ testGroup "deserialisation" + [ testFromXML "natural" + "123" (Nat 123) -encodeItems :: [(Item, LazyByteString)] -encodeItems = - [ ( Item (Just $ Nat 1) (Just 1) Nothing - , "{\"item_str\":null,\"item_nat\":1,\"item_int\":1}" - ) + , testFromXML "int" + (toLazyBS maxInt) maxInt - , ( Item (Just $ Nat 1) (Just 1) (Just "1") - , "{\"item_str\":\"1\",\"item_nat\":1,\"item_int\":1}" - ) - ] + , testFromXML "negative int" + (toLazyBS minInt) minInt -testEncode :: [(Item, LazyByteString)] -> TestTree -testEncode = testCase "Numeric JSON Encoding" - . mapM_ (\(input, e) -> e @=? encode input) + , testFromXML "integer" + "891324" (891324 :: Integer) -decodeItems :: [(Maybe Item, LazyByteString)] -decodeItems = - [ ( Just (Item (Just $ Nat 1) (Just 1) Nothing) - , "{\"item_nat\":1,\"item_int\":1}" - ) + , testFromXML "negative integer" + "-998" (-998 :: Integer) - , ( Just (Item (Just $ Nat 1) (Just (-1)) (Just "1")) - , "{\"item_nat\":1,\"item_int\":-1, \"item_str\":\"1\"}" - ) + , testFromXML "double" + "46.39212" (46.39212 :: Double) - , ( Nothing - , "{\"item_nat\":1,\"item_int\":-1, \"item_str\":1}" - ) + , testFromXML "negative double" + "-1.09231" (-1.09231 :: Double) - , ( Just (Item (Just $ Nat 1) (Just (-1)) Nothing) - , "{\"item_nat\":1,\"item_int\":-1}" - ) + , testFromXML "numeric string" + "22" ("22" :: Text) + ] - , ( Just (Item (Just $ Nat 1) (Just (-1)) Nothing) - , "{\"item_nat\":1.0,\"item_int\":-1}" - ) + , testGroup "serialisation" + [ testToXML "natural" + "123" (Nat 123) - , ( Nothing - , "{\"item_nat\":-1,\"item_int\":1}" - ) + , testToXML "int" + (toLazyBS maxInt) maxInt - , ( Nothing - , "{\"item_nat\":1.2,\"item_int\":1}" - ) + , testToXML "negative int" + (toLazyBS minInt) minInt - , ( Nothing - , "{\"item_nat\":\"1\",\"item_int\":1}" - ) - ] + , testToXML "integer" + "891324" (891324 :: Integer) -testDecode :: [(Maybe Item, LazyByteString)] -> TestTree -testDecode = testCase "Numeric JSON Decoding" . mapM_ check - where - check (e, input) = e @=? (decode input :: Maybe Item) + , testToXML "negative integer" + "-998" (-998 :: Integer) + + , testToXML "double" + "46.39212" (46.39212 :: Double) + + , testToXML "negative double" + "-1.09231" (-1.09231 :: Double) + + , testToXML "numeric text" + "22" ("22" :: Text) + ] + ] + ] 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 @@ -1,94 +1,156 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +-- | -- Module : Test.AWS.Data.Time --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : experimental -- Portability : non-portable (GHC extensions) - +-- module Test.AWS.Data.Time (tests) where -import Data.Aeson -import Network.AWS.Data +import Network.AWS.Compat.Locale +import Network.AWS.Compat.Time import Network.AWS.Prelude -import Test.AWS.Types +import Test.AWS.Util import Test.Tasty -import Test.Tasty.HUnit tests :: TestTree tests = testGroup "time" - [ testGroup "deserialise xml" - [ testCase "RFC822" $ - assertXML "Fri, 07 Nov 2014 04:42:13 GMT" (ref :: RFC822) - , testCase "ISO8601" $ - assertXML "2014-11-07T04:42:13.000Z" (ref :: ISO8601) - , testCase "AWS" $ - assertXML "20141107T044213Z" (ref :: AWSTime) - , testCase "POSIX integer" $ - assertXML "1415335333" (ref :: POSIX) - , testCase "POSIX scientific" $ - assertXML "1.415335333E9" (ref :: POSIX) + [ testGroup "text" + [ testGroup "deserialise" + [ testFromText "rfc822" + "Fri, 07 Nov 2014 04:42:13 GMT" (time :: RFC822) + + , testFromText "iso8601" + "2014-11-07T04:42:13.000Z" (time :: ISO8601) + + , testFromText "aws" + "20141107T044213Z" (time :: AWSTime) + + , testGroup "posix" + [ testFromText "integer" + "1415335333" (time :: POSIX) + + , testFromText "double" + "1415335333.000" (time :: POSIX) + + , testFromText "scientific" + "1.415335333E9" (time :: POSIX) + ] + ] + + , testGroup "serialise" + [ testToText "rfc822" + "Fri, 07 Nov 2014 04:42:13 GMT" (time :: RFC822) + + , testToText "iso8601" + "2014-11-07T04:42:13UTC" (time :: ISO8601) + + , testToText "aws" + "20141107T044213Z" (time :: AWSTime) + + , testToText "posix" + "1415335333" (time :: POSIX) + ] ] - , testGroup "deserialise json" - [ testCase "RFC822" $ - assertJSON "{\"time_rfc\":\"Fri, 07 Nov 2014 04:42:13 GMT\"}" - (defaultTimeItem {timeRFC = Just ref}) - , testCase "ISO8601" $ - assertJSON "{\"time_iso\":\"2014-11-07T04:42:13.000Z\"}" - (defaultTimeItem {timeISO = Just ref}) - , testCase "AWS" $ - assertJSON "{\"time_aws\":\"20141107T044213Z\"}" - (defaultTimeItem {timeAWS = Just ref}) - , testCase "POSIX integer" $ - assertJSON "{\"time_posix\":1415335333}" - (defaultTimeItem {timePOSIX = Just ref}) - , testCase "POSIX scientific" $ - assertJSON "{\"time_posix\":1.415335333E9}" - (defaultTimeItem {timePOSIX = Just ref}) + + , testGroup "query" + [ testGroup "serialise" + [ testToQuery "rfc822" + "x=Fri%2C%2007%20Nov%202014%2004%3A42%3A13%20GMT" (time :: RFC822) + + , testToQuery "iso8601" + "x=2014-11-07T04%3A42%3A13UTC" (time :: ISO8601) + + , testToQuery "aws" + "x=20141107T044213Z" (time :: AWSTime) + ] ] - , testGroup "serialise json" - [ testCase "POSIX integer" $ - (@?=) (encode $ defaultTimeItem {timePOSIX = Just ref}) - "{\"time_aws\":null,\"time_iso\":null,\ - \\"time_posix\":1415335333,\"time_rfc\":null}" + + , testGroup "xml" + [ testGroup "deserialise" + [ testFromXML "rfc822" + "Fri, 07 Nov 2014 04:42:13 GMT" (time :: RFC822) + + , testFromXML "iso8601" + "2014-11-07T04:42:13.000Z" (time :: ISO8601) + + , testFromXML "aws" + "20141107T044213Z" (time :: AWSTime) + + , testGroup "posix" + [ testFromXML "integer" + "1415335333" (time :: POSIX) + + , testFromXML "double" + "1415335333.000" (time :: POSIX) + + , testFromXML "scientific" + "1.415335333E9" (time :: POSIX) + ] + ] + + , testGroup "serialise" + [ testToXML "rfc822" + "Fri, 07 Nov 2014 04:42:13 GMT" (time :: RFC822) + + , testToXML "iso8601" + "2014-11-07T04:42:13UTC" (time :: ISO8601) + + , testToXML "aws" + "20141107T044213Z" (time :: AWSTime) + + , testToXML "posix" + "1415335333" (time :: POSIX) + ] ] - ] -ref :: Time a -ref = Time $ fromMaybe (error "Unable to parse time") (parseTime locale format ts) - where - locale = defaultTimeLocale - format = iso8601DateFormat (Just "%H:%M:%S") - ts = "2014-11-07T04:42:13" + , testGroup "json" + [ testGroup "deserialise" + [ testFromJSON "rfc822" + (str "Fri, 07 Nov 2014 04:42:13 GMT") (time :: RFC822) -data TimeItem = TimeItem - { timeRFC :: Maybe RFC822 - , timeISO :: Maybe ISO8601 - , timeAWS :: Maybe AWSTime - , timePOSIX :: Maybe POSIX - } deriving (Eq, Show) + , testFromJSON "iso8601" + (str "2014-11-07T04:42:13.000Z") (time :: ISO8601) -defaultTimeItem :: TimeItem -defaultTimeItem = TimeItem Nothing Nothing Nothing Nothing + , testFromJSON "aws" + (str "20141107T044213Z") (time :: AWSTime) -instance ToJSON TimeItem where - toJSON TimeItem{..} = object - [ "time_rfc" .= timeRFC - , "time_iso" .= timeISO - , "time_aws" .= timeAWS - , "time_posix" .= timePOSIX + , testGroup "posix" + [ testFromJSON "integer" + "1415335333" (time :: POSIX) + + , testFromJSON "double" + "1415335333.000" (time :: POSIX) + + , testFromJSON "scientific" + "1.415335333E9" (time :: POSIX) + ] + ] + + , testGroup "serialise" + [ testToJSON "rfc822" + (str "Fri, 07 Nov 2014 04:42:13 GMT") (time :: RFC822) + + , testToJSON "iso8601" + (str "2014-11-07T04:42:13UTC") (time :: ISO8601) + + , testToJSON "aws" + (str "20141107T044213Z") (time :: AWSTime) + + , testToJSON "posix" + "1415335333" (time :: POSIX) + ] ] + ] -instance FromJSON TimeItem where - parseJSON = withObject "TimeItem" $ \o -> TimeItem - <$> o .:? "time_rfc" - <*> o .:? "time_iso" - <*> o .:? "time_aws" - <*> o .:? "time_posix" +time :: Time a +time = Time . fromMaybe (error msg) $ parseTime defaultTimeLocale fmt ts + where + msg = "Unable to parse time: " ++ ts + fmt = (iso8601DateFormat (Just "%H:%M:%S")) + ts = "2014-11-07T04:42:13" diff --git a/test/Test/AWS/Sign/V4.hs b/test/Test/AWS/Sign/V4.hs new file mode 100644 --- /dev/null +++ b/test/Test/AWS/Sign/V4.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Test.AWS.Sign.V$ +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +module Test.AWS.Sign.V4 (tests) where + +import Control.Lens +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 + +-- Write some V4 signing properties: +-- test canonical query +-- test query +-- test canonical headers +-- test signed headers +-- test time format +-- test host, x-amz-date, content-sha256 headers exist +-- test empty path +-- test empty query + +tests :: TestTree +tests = testGroup "v4" + [ testGroup "canonical query" + [ testProperty "empty" $ queryEmpty + , testProperty "empty key values" $ queryEmptyKeyValues + ] + ] + +queryEmpty :: Request () -> Signer -> Property +queryEmpty rq sg = property $ + mempty == toBS (metaCanonicalQuery . sign sg $ rq & rqQuery .~ mempty) + +queryEmptyKeyValues :: [NonEmptyList Char] -> Property +queryEmptyKeyValues xs = property $ do + rq <- arbitrary + sg <- arbitrary + + let v4 = sign sg $ rq & rqQuery .~ Fold.foldMap (fromString . getNonEmpty) xs + + e = sort $ map ((<> "=") . urlEncode True . BS8.pack . getNonEmpty) xs + a = BS8.split '&' . toBS $ metaCanonicalQuery v4 + + m = "Expected: " ++ show e ++ "\n" ++ + "Actual: " ++ show a + + return . counterexample m $ e == a + +newtype Signer = Signer { sign :: Request () -> Meta V4 } + +instance Show Signer where + show = const "V4" + +instance Arbitrary Signer where + arbitrary = do + a <- arbitrary + reg <- arbitrary + ts <- arbitrary + return $ Signer (_sgMeta . signed auth reg ts (testV4 a)) + +auth :: AuthEnv +auth = AuthEnv "access-key" "super-secret-key" Nothing Nothing + +data TestV4 + +instance AWSService TestV4 where + type Sg TestV4 = V4 + + service = error "service not defined for TestV4." + +testV4 :: Abbrev -> Service TestV4 +testV4 a = svc + where + svc = Service + { _svcAbbrev = a + , _svcPrefix = Text.encodeUtf8 . Text.toLower $ toText a + , _svcVersion = "2012-01-01" + , _svcEndpoint = defaultEndpoint svc + , _svcTimeout = Nothing + , _svcStatus = const False + , _svcError = error "_svcError not defined." + , _svcRetry = error "_svcRetry not defined." + } diff --git a/test/Test/AWS/TH.hs b/test/Test/AWS/TH.hs deleted file mode 100644 --- a/test/Test/AWS/TH.hs +++ /dev/null @@ -1,17 +0,0 @@ --- Module : Test.AWS.TH --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Test.AWS.TH where - -import Language.Haskell.TH -import Language.Haskell.TH.Quote - -doc :: QuasiQuoter -doc = QuasiQuoter { quoteExp = stringE } diff --git a/test/Test/AWS/Types.hs b/test/Test/AWS/Types.hs deleted file mode 100644 --- a/test/Test/AWS/Types.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Module : Test.AWS.Types --- Copyright : (c) 2013-2015 Brendan Hay --- License : This Source Code Form is subject to the terms of --- the Mozilla Public License, v. 2.0. --- A copy of the MPL can be found in the LICENSE file or --- you can obtain it at http://mozilla.org/MPL/2.0/. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) - -module Test.AWS.Types where - -import Data.Aeson -import Network.AWS.Data -import Network.AWS.Prelude -import Test.Tasty.HUnit - -newtype Entries a = Entries a - deriving (Eq, Show) - -instance FromXML a => FromXML (Entries a) where - parseXML x = Entries <$> x .@ "Entries" - -assertXML :: (FromXML a, Show a, Eq a) => LazyByteString -> a -> Assertion -assertXML s x = (decodeXML s >>= parseXML) @?= Right x - -assertJSON :: (FromJSON a, Show a, Eq a) => LazyByteString -> a -> Assertion -assertJSON s x = eitherDecode' s @?= Right x diff --git a/test/Test/AWS/Util.hs b/test/Test/AWS/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/AWS/Util.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Test.AWS.Util +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +module Test.AWS.Util where + +import Data.Aeson +import qualified Data.ByteString.Lazy as LBS +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Network.AWS.Prelude +import Test.Tasty +import Test.Tasty.HUnit + +doc :: QuasiQuoter +doc = QuasiQuoter + { quoteExp = stringE + , quotePat = const $ error "No quotePat defined." + , quoteType = const $ error "No quoteType defined." + , quoteDec = const $ error "No quoteDec defined." + } + +-- | Dummy root element for testing nested structures. +newtype X a = X a + deriving (Eq, Show) + +instance ToQuery a => ToQuery (X a) where + toQuery (X x) = "x" =: x + +instance FromXML a => FromXML (X a) where + parseXML = fmap X . parseXML + +instance ToXML a => ToElement (X a) where + toElement (X x) = mkElement "x" x + +instance FromJSON a => FromJSON (X a) where + parseJSON = withObject "X" (fmap X . (.: "x")) + +instance ToJSON a => ToJSON (X a) where + toJSON (X x) = object ["x" .= x] + +testFromText :: (FromText a, Show a, Eq a) + => TestName + -> Text + -> a + -> TestTree +testFromText n t x = testCase n (Right x @?= fromText t) + +testToText :: (ToText a, Show a, Eq a) + => TestName + -> Text + -> a + -> TestTree +testToText n t x = testCase n (t @?= toText x) + +testToQuery :: (ToQuery a, Show a, Eq a) + => TestName + -> ByteString + -> a + -> TestTree +testToQuery n bs x = testCase n (bs @=? toBS (toQuery (X x))) + +testFromXML :: (FromXML a, Show a, Eq a) + => TestName + -> LazyByteString + -> a + -> TestTree +testFromXML n bs x = testCase n $ + Right (X x) @?= (decodeXML (wrapXML bs) >>= parseXML) + +testToXML :: (ToXML a, Show a, Eq a) + => TestName + -> LazyByteString + -> a + -> TestTree +testToXML n bs x = testCase n $ wrapXML bs @?= encodeXML (X x) + +testFromJSON :: (FromJSON a, Show a, Eq a) + => TestName + -> LazyByteString + -> a + -> TestTree +testFromJSON n bs x = testCase n $ + Right (X x) @?= eitherDecode' ("{\"x\":" <> bs <> "}") + +testToJSON :: (ToJSON a, Show a, Eq a) + => TestName + -> LazyByteString + -> a + -> TestTree +testToJSON n bs x = testCase n (bs @?= encode x) + +str :: LazyByteString -> LazyByteString +str bs = "\"" <> bs <> "\"" + +wrapXML :: LazyByteString -> LazyByteString +wrapXML bs = + "" <> "" <> bs <> "" + +maxInt :: Int +maxInt = maxBound + +minInt :: Int +minInt = minBound + +toLazyBS :: ToByteString a => a -> LazyByteString +toLazyBS = LBS.fromStrict . toBS