diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,24 +0,0 @@ -# Amazonka Core - -* [Description](#description) -* [Contribute](#contribute) -* [Licence](#licence) - -## Description - -Core functionality, serialisation primitives, and data types 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 -for use in non-Amazonka projects. - - -## Contribute - -For any problems, comments, or feedback please create an issue [here on GitHub](https://github.com/brendanhay/amazonka/issues). - - -## Licence - -`amazonka-core` is released under the [Mozilla Public License Version 2.0](http://www.mozilla.org/MPL/). diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/amazonka-core.cabal b/amazonka-core.cabal --- a/amazonka-core.cabal +++ b/amazonka-core.cabal @@ -1,163 +1,168 @@ -name: amazonka-core -version: 1.6.1 -synopsis: Core data types and functionality for Amazonka libraries. -homepage: https://github.com/brendanhay/amazonka -bug-reports: https://github.com/brendanhay/amazonka/issues -license: MPL-2.0 -license-file: LICENSE -author: Brendan Hay -maintainer: Brendan Hay -copyright: Copyright (c) 2013-2017 Brendan Hay -category: Network, AWS, Cloud, Distributed Computing -build-type: Simple -extra-source-files: README.md -cabal-version: >= 1.10 +cabal-version: 2.2 +name: amazonka-core +version: 2.0 +synopsis: Core data types and functionality for Amazonka libraries. +homepage: https://github.com/brendanhay/amazonka +bug-reports: https://github.com/brendanhay/amazonka/issues +license: MPL-2.0 +license-file: LICENSE +author: Brendan Hay +maintainer: + Brendan Hay , Jack Kelly +copyright: Copyright (c) 2013-2023 Brendan Hay +category: AWS +build-type: Simple description: - 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 not suitable - for use in non-Amazonka projects. + Core data types and serialisation primitives for Amazonka related Amazon Web Service SDKs. + . + The external interface of this library is stable with respect to the downstream + Amazonka libraries only, and is not suitable for use in non-Amazonka projects. source-repository head - type: git - location: git://github.com/brendanhay/amazonka.git - subdir: core - -flag old-locale - description: Use old-locale and time < 1.5 - default: False - -library - default-language: Haskell2010 - hs-source-dirs: src - - ghc-options: - -Wall - -fwarn-incomplete-uni-patterns - -fwarn-incomplete-record-updates - -funbox-strict-fields + type: git + location: git://github.com/brendanhay/amazonka.git + subdir: lib/amazonka-core - exposed-modules: - 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.Lens - , Network.AWS.Pager - , Network.AWS.Prelude - , Network.AWS.Request - , Network.AWS.Response - , Network.AWS.Sign.V2Header - , Network.AWS.Sign.V2Header.Base - , Network.AWS.Sign.V2 - , Network.AWS.Sign.V4 - , Network.AWS.Types - , Network.AWS.Waiter +common base + default-language: Haskell2010 + ghc-options: + -Wall -funbox-strict-fields -fwarn-incomplete-uni-patterns + -fwarn-incomplete-record-updates -fwarn-missing-deriving-strategies + -fwarn-unused-packages - other-modules: - Network.AWS.Sign.V4.Base - , Network.AWS.Sign.V4.Chunked + default-extensions: + NoImplicitPrelude + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + PackageImports + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + ViewPatterns - build-depends: - aeson >= 0.8 - , attoparsec >= 0.11.3 - , base >= 4.7 && < 5 - , bifunctors >= 4.1 - , bytestring >= 0.9 - , case-insensitive >= 1.2 - , conduit >= 1.1 - , conduit-extra >= 1.1 - , cryptonite >= 0.4 - , deepseq >= 1.4 - , exceptions >= 0.6 - , hashable >= 1.2 - , http-client >= 0.4 && < 0.6 - , http-conduit >= 2.1.4 && < 3 - , http-types >= 0.8 && (<0.11 || >=0.12) - , lens >= 4.4 - , memory >= 0.6 - , mtl >= 2.1.3.1 - , resourcet >= 1.1 - , scientific >= 0.3 - , semigroups >= 0.12 - , tagged >= 0.7 - , text >= 1.1 - , transformers >= 0.2 - , transformers-compat >= 0.3 - , unordered-containers >= 0.2.7 - , xml-conduit >= 1.7.0.1 - , xml-types >= 0.3.4 + build-depends: base >=4.12 && <5 - if !impl(ghc>=7.9) - build-depends: - nats >= 0.1.3 +library + import: base + hs-source-dirs: src + exposed-modules: + Amazonka.Bytes + Amazonka.Core + Amazonka.Core.Lens + Amazonka.Core.Lens.Internal + Amazonka.Crypto + Amazonka.Data + Amazonka.Data.Base64 + Amazonka.Data.Body + Amazonka.Data.ByteString + Amazonka.Data.Headers + Amazonka.Data.JSON + Amazonka.Data.Log + Amazonka.Data.Path + Amazonka.Data.Query + Amazonka.Data.Sensitive + Amazonka.Data.Text + Amazonka.Data.Time + Amazonka.Data.XML + Amazonka.Endpoint + Amazonka.Error + Amazonka.Pager + Amazonka.Prelude + Amazonka.Request + Amazonka.Response + Amazonka.Sign.V2 + Amazonka.Sign.V2Header + Amazonka.Sign.V4 + Amazonka.Sign.V4.Base + Amazonka.Sign.V4.Chunked + Amazonka.Types + Amazonka.Waiter - if flag(old-locale) - build-depends: - old-locale == 1.* - , time >= 1.2 && < 1.5 - else - build-depends: - time >= 1.5 + build-depends: + , aeson ^>=1.5.0.0 || >=2.0 && <2.2 || ^>=2.2 + , attoparsec >=0.11.3 + , bytestring >=0.10.8 + , case-insensitive >=1.2 + , conduit >=1.3 + , conduit-extra >=1.3 + , containers >=0.5 && <0.7 + , crypton >=0.32 && <0.34 + , deepseq >=1.4 + , hashable >=1.2 + , http-client >=0.5 && <0.8 + , http-conduit >=2.3 && <3 + , http-types >=0.12 + , lens >=4.14 + , memory >=0.6 + , regex-posix >=0.96 + , resourcet >=1.1 + , scientific >=0.3 + , text >=1.1 + , time >=1.9 + , transformers >=0.2 + , unordered-containers >=0.2.7 + , xml-conduit >=1.7.0.1 + , xml-types >=0.3.4 test-suite tests - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: test - main-is: Main.hs - - ghc-options: -Wall -threaded - - other-modules: - Test.AWS.Arbitrary - , Test.AWS.Data.Base64 - , Test.AWS.Data.List - , Test.AWS.Data.Maybe - , Test.AWS.Data.Numeric - , Test.AWS.Data.Path - , Test.AWS.Data.Query - , Test.AWS.Data.Time - , Test.AWS.Error - , Test.AWS.Sign.V2Header.BaseSpec - , Test.AWS.Sign.V4 - , Test.AWS.Sign.V4.Chunked - , Test.AWS.Util + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -Wall -threaded + other-modules: + Test.Amazonka.Arbitrary + Test.Amazonka.Data.Base64 + Test.Amazonka.Data.List + Test.Amazonka.Data.Maybe + Test.Amazonka.Data.Numeric + Test.Amazonka.Data.Path + Test.Amazonka.Data.Query + Test.Amazonka.Data.Time + Test.Amazonka.Error + Test.Amazonka.Sign.V2Header + Test.Amazonka.Sign.V4 + Test.Amazonka.Sign.V4.Base + Test.Amazonka.Sign.V4.Chunked + Test.Amazonka.Util - build-depends: - aeson - , amazonka-core - , base - , bytestring - , case-insensitive - , conduit - , data-ordlist - , http-conduit - , http-types - , lens - , QuickCheck - , quickcheck-unicode - , tasty - , tasty-hunit - , tasty-quickcheck - , template-haskell - , text - , time + build-depends: + , aeson + , amazonka-core + , bytestring + , case-insensitive + , conduit + , data-ordlist + , http-conduit + , http-types + , QuickCheck + , quickcheck-unicode + , tasty + , tasty-hunit + , tasty-quickcheck + , template-haskell + , text + , time diff --git a/src/Amazonka/Bytes.hs b/src/Amazonka/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Bytes.hs @@ -0,0 +1,31 @@ +-- | +-- Module : Amazonka.Bytes +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Bytes + ( convert, + encodeBase16, + decodeBase16, + encodeBase64, + decodeBase64, + ) +where + +import Amazonka.Prelude +import Data.ByteArray (ByteArrayAccess, convert) +import qualified Data.ByteArray.Encoding as ByteArray.Encoding + +encodeBase16 :: ByteArrayAccess a => a -> ByteString +encodeBase16 = ByteArray.Encoding.convertToBase ByteArray.Encoding.Base16 + +decodeBase16 :: ByteArrayAccess a => a -> Either String ByteString +decodeBase16 = ByteArray.Encoding.convertFromBase ByteArray.Encoding.Base16 + +encodeBase64 :: ByteArrayAccess a => a -> ByteString +encodeBase64 = ByteArray.Encoding.convertToBase ByteArray.Encoding.Base64 + +decodeBase64 :: ByteArrayAccess a => a -> Either String ByteString +decodeBase64 = ByteArray.Encoding.convertFromBase ByteArray.Encoding.Base64 diff --git a/src/Amazonka/Core.hs b/src/Amazonka/Core.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Core.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Amazonka.Core +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Types and values referenced by generated code. +module Amazonka.Core + ( module Amazonka.Types, + module Amazonka.Endpoint, + module Amazonka.Data, + module Amazonka.Pager, + module Amazonka.Waiter, + module Amazonka.Error, + (.!@), + may, + ) +where + +-- Export Amazonka.Data submodules piecemeal and avoid exporting AWS +-- encoding/decoding modules, so we don't leak too much to library +-- clients. Service bindings import Amazonka.Data directly. +import Amazonka.Data.Base64 as Amazonka.Data +import Amazonka.Data.Body as Amazonka.Data +import Amazonka.Data.Log as Amazonka.Data +import Amazonka.Data.Sensitive as Amazonka.Data +import Amazonka.Data.Time as Amazonka.Data +import Amazonka.Endpoint +import Amazonka.Error +import Amazonka.Pager +import Amazonka.Prelude +import Amazonka.Types +import Amazonka.Waiter + +-- Legacy code generation operators + +infixl 7 .!@ + +(.!@) :: 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/Amazonka/Core/Lens.hs b/src/Amazonka/Core/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Core/Lens.hs @@ -0,0 +1,125 @@ +-- | +-- Module : Amazonka.Core.Lens +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Re-export lenses and other optics for types in @amazonka-core@. You +-- will probably find record updates, +-- [generic-lens](https://hackage.haskell.org/package/generic-lens), +-- [generic-optics](https://hackage.haskell.org/package/generic-optics), +-- or (GHC >=9.2) @-XOverloadedRecordDot@ more ergonomic than these. +module Amazonka.Core.Lens + ( -- * Amazonka.Data.Body + + -- ** ResponseBody + _ResponseBody, + + -- ** ChunkSize + _ChunkSize, + + -- ** ChunkedBody + chunkedBody_size, + chunkedBody_length, + chunkedBody_body, + + -- * Amazonka.Data.Time + _Time, + + -- * Amazonka.Types + + -- ** Abbrev + _Abbrev, + + -- ** AccessKey + _AccessKey, + + -- ** AuthEnv + authEnv_accessKeyId, + authEnv_secretAccessKey, + authEnv_sessionToken, + authEnv_expiration, + + -- ** Endpoint + endpoint_host, + endpoint_basePath, + endpoint_secure, + endpoint_port, + endpoint_scope, + + -- ** ErrorCode + _ErrorCode, + + -- ** ErrorMessage + _ErrorMessage, + + -- ** Request + request_service, + request_method, + request_path, + request_query, + request_headers, + request_body, + + -- ** RequestId + _RequestId, + + -- ** Retry + retry_base, + retry_growth, + retry_attempts, + retry_check, + + -- ** SecretKey + _SecretKey, + + -- ** SessionToken + _SessionToken, + + -- ** SerializeError + serializeError_abbrev, + serializeError_status, + serializeError_body, + serializeError_message, + + -- ** Service + service_abbrev, + service_signer, + service_signingName, + service_version, + service_s3AddressingStyle, + service_endpointPrefix, + service_endpoint, + service_timeout, + service_check, + service_error, + service_retry, + + -- ** ServiceError + serviceError_abbrev, + serviceError_status, + serviceError_headers, + serviceError_code, + serviceError_message, + serviceError_requestId, + + -- ** Signed + signed_signedMeta, + signed_signedRequest, + + -- * Amazonka.Waiter + + -- ** Wait + wait_name, + wait_attempts, + wait_delay, + wait_acceptors, + ) +where + +import Amazonka.Data.Body +import Amazonka.Data.Time +import Amazonka.Types +import Amazonka.Waiter diff --git a/src/Amazonka/Core/Lens/Internal.hs b/src/Amazonka/Core/Lens/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Core/Lens/Internal.hs @@ -0,0 +1,65 @@ +-- | +-- Module : Amazonka.Core.Lens.Internal +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Re-export a number of lens types and combinators for use in service +-- bindings. +module Amazonka.Core.Lens.Internal (module Export) where + +import Control.Exception.Lens as Export + ( catching, + catching_, + exception, + throwingM, + trying, + _IOException, + ) +import Control.Lens as Export + ( AReview, + Choice, + Fold, + Getter, + Getting, + IndexedTraversal', + Iso', + Lens, + Lens', + Optic', + Prism', + Setter', + Traversal', + allOf, + anyOf, + coerced, + concatOf, + filtered, + folding, + has, + iso, + lens, + mapping, + non, + prism, + sets, + to, + traversed, + un, + view, + (#), + (%~), + (.~), + (<&>), + (<>~), + (?~), + (^.), + (^..), + (^?), + _1, + _2, + _Just, + _last, + ) diff --git a/src/Amazonka/Crypto.hs b/src/Amazonka/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Crypto.hs @@ -0,0 +1,76 @@ +-- | +-- Module : Amazonka.Crypto +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Crypto + ( -- * HMAC + Key, + hmacSHA1, + hmacSHA256, + + -- * Hashing + hashSHA1, + hashSHA256, + hashMD5, + Hash.hash, + --- * Incremental Hashing + sinkSHA256, + sinkMD5, + + -- * Re-exported + Hash.HashAlgorithm, + Hash.Digest, + Hash.SHA256, + Hash.MD5, + ) +where + +import Amazonka.Prelude +import qualified Crypto.Hash as Hash +import qualified Crypto.MAC.HMAC as HMAC +import Data.ByteArray (ByteArrayAccess) +import Data.Conduit (ConduitM) +import qualified Data.Conduit as Conduit + +type Key = ByteString + +hmacSHA1 :: ByteArrayAccess a => Key -> a -> HMAC.HMAC Hash.SHA1 +hmacSHA1 = HMAC.hmac + +hmacSHA256 :: ByteArrayAccess a => Key -> a -> HMAC.HMAC Hash.SHA256 +hmacSHA256 = HMAC.hmac + +hashSHA1 :: ByteArrayAccess a => a -> Hash.Digest Hash.SHA1 +hashSHA1 = Hash.hashWith Hash.SHA1 + +hashSHA256 :: ByteArrayAccess a => a -> Hash.Digest Hash.SHA256 +hashSHA256 = Hash.hashWith Hash.SHA256 + +hashMD5 :: ByteArrayAccess a => a -> Hash.Digest Hash.MD5 +hashMD5 = Hash.hashWith Hash.MD5 + +-- | Incrementally calculate a 'MD5' 'Digest'. +sinkMD5 :: Monad m => ConduitM ByteString o m (Hash.Digest Hash.MD5) +sinkMD5 = sinkHash + +-- | Incrementally calculate a 'SHA256' 'Digest'. +sinkSHA256 :: Monad m => ConduitM ByteString o m (Hash.Digest Hash.SHA256) +sinkSHA256 = sinkHash + +-- | A crypton-compatible incremental hash sink. +sinkHash :: + ( Monad m, + Hash.HashAlgorithm a + ) => + ConduitM ByteString o m (Hash.Digest a) +sinkHash = sink Hash.hashInit + where + sink ctx = do + mbs <- Conduit.await + + case mbs of + Nothing -> pure $! Hash.hashFinalize ctx + Just bs -> sink $! Hash.hashUpdate ctx bs diff --git a/src/Amazonka/Data.hs b/src/Amazonka/Data.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data.hs @@ -0,0 +1,24 @@ +-- | +-- Module : Amazonka.Data +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data + ( module Export, + ) +where + +import Amazonka.Data.Base64 as Export +import Amazonka.Data.Body as Export +import Amazonka.Data.ByteString as Export +import Amazonka.Data.Headers as Export +import Amazonka.Data.JSON as Export +import Amazonka.Data.Log as Export +import Amazonka.Data.Path as Export +import Amazonka.Data.Query as Export +import Amazonka.Data.Sensitive as Export +import Amazonka.Data.Text as Export +import Amazonka.Data.Time as Export +import Amazonka.Data.XML as Export diff --git a/src/Amazonka/Data/Base64.hs b/src/Amazonka/Data/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/Base64.hs @@ -0,0 +1,71 @@ +-- | +-- Module : Amazonka.Data.Base64 +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.Base64 + ( Base64 (..), + _Base64, + ) +where + +import qualified Amazonka.Bytes as Bytes +import Amazonka.Core.Lens.Internal (iso) +import Amazonka.Data.Body +import Amazonka.Data.ByteString +import Amazonka.Data.JSON +import Amazonka.Data.Query +import Amazonka.Data.Text +import Amazonka.Data.XML +import Amazonka.Prelude +import qualified Data.Text.Encoding as Text + +-- | Base64 encoded binary data. +-- +-- Encoding\/decoding is automatically deferred to serialisation and deserialisation +-- respectively. +newtype Base64 = Base64 {unBase64 :: ByteString} + deriving stock (Eq, Read, Ord, Generic) + +instance Hashable Base64 + +instance NFData Base64 + +_Base64 :: Iso' Base64 ByteString +_Base64 = iso unBase64 Base64 + +-- FIXME: a mistake to wrap a ByteString since the underlying serialisers +-- (JSON, XML) use Text internally. +instance FromText Base64 where + fromText = fmap Base64 . Bytes.decodeBase64 . Text.encodeUtf8 + +instance ToByteString Base64 where + toBS = Bytes.encodeBase64 . 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 + +instance ToHashedBody Base64 where + toHashed = toHashed . toBS + +instance ToBody Base64 diff --git a/src/Amazonka/Data/Body.hs b/src/Amazonka/Data/Body.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/Body.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Amazonka.Data.Body +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.Body where + +import qualified Amazonka.Bytes as Bytes +import Amazonka.Core.Lens.Internal (coerced) +import Amazonka.Crypto (Digest, SHA256) +import qualified Amazonka.Crypto as Crypto +import Amazonka.Data.ByteString +import Amazonka.Data.Log +import Amazonka.Data.Query (QueryString) +import Amazonka.Data.XML (encodeXML) +import Amazonka.Prelude hiding (length) +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.Conduit (ConduitM, (.|)) +import qualified Data.Conduit as Conduit +import qualified Data.Conduit.Binary as Conduit.Binary +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy.Encoding as LText +import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Conduit as Client.Conduit +import qualified System.IO as IO +import qualified Text.XML as XML + +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson.KeyMap (KeyMap) +#endif + +-- | Convenience function for obtaining the size of a file. +getFileSize :: MonadIO m => FilePath -> m Integer +getFileSize path = liftIO (IO.withBinaryFile path IO.ReadMode IO.hFileSize) + +-- | A streaming, exception safe response body. +-- +-- @newtype@ for show/orhpan instance purposes. +newtype ResponseBody = ResponseBody + {body :: ConduitM () ByteString (ResourceT IO) ()} + deriving stock (Generic) + +instance Show ResponseBody where + show = const "ResponseBody { ConduitM () ByteString (ResourceT IO) () }" + +{-# INLINE _ResponseBody #-} +_ResponseBody :: Iso' ResponseBody (ConduitM () ByteString (ResourceT IO) ()) +_ResponseBody = coerced + +fuseStream :: + ResponseBody -> + ConduitM ByteString ByteString (ResourceT IO) () -> + ResponseBody +fuseStream b@ResponseBody {body} f = b {body = body .| f} + +-- | Connect a 'Sink' to a response stream. +sinkBody :: MonadIO m => ResponseBody -> ConduitM ByteString Void (ResourceT IO) a -> m a +sinkBody (ResponseBody body) sink = + liftIO $ Conduit.runConduitRes $ body .| sink + +-- | Specifies the transmitted size of the 'Transfer-Encoding' chunks. +-- +-- /See:/ 'defaultChunk'. +newtype ChunkSize = ChunkSize Int + deriving stock (Eq, Ord, Show) + deriving newtype (Enum, Num, Real, Integral) + +instance ToLog ChunkSize where + build = build . show + +_ChunkSize :: Iso' ChunkSize Int +_ChunkSize = coerced + +-- | The default chunk size of 128 KB. The minimum chunk size accepted by +-- AWS is 8 KB, unless the entirety of the request is below this threshold. +-- +-- A chunk size of 64 KB or higher is recommended for performance reasons. +defaultChunkSize :: ChunkSize +defaultChunkSize = 128 * 1024 + +-- | An opaque request body which will be transmitted via +-- @Transfer-Encoding: chunked@. +-- +-- /Invariant:/ Only services that support chunked encoding can +-- accept a 'ChunkedBody'. (Currently S3.) This is enforced by the type +-- signatures emitted by the generator. +data ChunkedBody = ChunkedBody + { size :: ChunkSize, + length :: Integer, + body :: ConduitM () ByteString (ResourceT IO) () + } + +{-# INLINE chunkedBody_size #-} +chunkedBody_size :: Lens' ChunkedBody ChunkSize +chunkedBody_size f b@ChunkedBody {size} = f size <&> \size' -> b {size = size'} + +{-# INLINE chunkedBody_length #-} +chunkedBody_length :: Lens' ChunkedBody Integer +chunkedBody_length f b@ChunkedBody {length} = f length <&> \length' -> b {length = length'} + +{-# INLINE chunkedBody_body #-} +chunkedBody_body :: Lens' ChunkedBody (ConduitM () ByteString (ResourceT IO) ()) +chunkedBody_body f b@ChunkedBody {body} = f body <&> \body' -> (b :: ChunkedBody) {body = body'} + +-- Maybe revert to using Source's, and then enforce the chunk size +-- during conversion from HashedBody -> ChunkedBody + +instance Show ChunkedBody where + show c = + BS8.unpack . toBS $ + "ChunkedBody { chunkSize = " + <> build (size c) + <> "<> originalLength = " + <> build (length c) + <> "<> fullChunks = " + <> build (fullChunks c) + <> "<> remainderBytes = " + <> build (remainderBytes c) + <> "}" + +fuseChunks :: + ChunkedBody -> + ConduitM ByteString ByteString (ResourceT IO) () -> + ChunkedBody +fuseChunks c@ChunkedBody {body} f = c {body = body .| f} + +fullChunks :: ChunkedBody -> Integer +fullChunks c = length c `div` fromIntegral (size c) + +remainderBytes :: ChunkedBody -> Maybe Integer +remainderBytes ChunkedBody {length, size} = + case length `mod` toInteger size of + 0 -> Nothing + n -> Just n + +-- | Construct a 'ChunkedBody' from a 'FilePath', where the contents will be +-- read and signed incrementally in chunks if the target service supports it. +-- +-- Will intelligently revert to 'HashedBody' if the file is smaller than the +-- specified 'ChunkSize'. +-- +-- /See:/ 'ToBody'. +chunkedFile :: MonadIO m => ChunkSize -> FilePath -> m RequestBody +chunkedFile chunk path = do + size <- getFileSize path + if size > toInteger chunk + then return $ unsafeChunkedBody chunk size (sourceFileChunks chunk path) + else Hashed <$> hashedFile path + +-- | Construct a 'ChunkedBody' from a 'FilePath', specifying the range of bytes +-- to read. This can be useful for constructing multiple requests from a single +-- file, say for S3 multipart uploads. +-- +-- /See:/ 'chunkedFile'. +chunkedFileRange :: + MonadIO m => + -- | The idealized size of chunks that will be yielded downstream. + ChunkSize -> + -- | The file path to read. + FilePath -> + -- | The byte offset at which to start reading. + Integer -> + -- | The maximum number of bytes to read. + Integer -> + m RequestBody +chunkedFileRange chunk path offset len = do + size <- getFileSize path + let n = min (size - offset) len + if n > toInteger chunk + then return $ unsafeChunkedBody chunk n (sourceFileRangeChunks chunk path offset len) + else Hashed <$> hashedFileRange path offset len + +-- | Unsafely construct a 'ChunkedBody'. +-- +-- This function is marked unsafe because it does nothing to enforce the chunk size. +-- Typically for conduit 'IO' functions, it's whatever ByteString's +-- 'defaultBufferSize' is, around 32 KB. If the chunk size is less than 8 KB, +-- the request will error. 64 KB or higher chunk size is recommended for +-- performance reasons. +-- +-- Note that it will always create a chunked body even if the request +-- is too small. +-- +-- /See:/ 'ToBody'. +unsafeChunkedBody :: + -- | The idealized size of chunks that will be yielded downstream. + ChunkSize -> + -- | The size of the stream in bytes. + Integer -> + ConduitM () ByteString (ResourceT IO) () -> + RequestBody +unsafeChunkedBody chunk size = Chunked . ChunkedBody chunk size + +sourceFileChunks :: + MonadResource m => + ChunkSize -> + FilePath -> + ConduitM () ByteString m () +sourceFileChunks (ChunkSize chunk) path = + Conduit.bracketP (IO.openBinaryFile path IO.ReadMode) IO.hClose go + where + -- Uses hGet with a specific buffer size, instead of hGetSome. + go hd = do + bs <- liftIO (BS.hGet hd chunk) + unless (BS.null bs) $ do + Conduit.yield bs + go hd + +sourceFileRangeChunks :: + MonadResource m => + -- | The idealized size of chunks that will be yielded downstream. + ChunkSize -> + -- | The file path to read. + FilePath -> + -- | The byte offset at which to start reading. + Integer -> + -- | The maximum number of bytes to read. + Integer -> + ConduitM () ByteString m () +sourceFileRangeChunks (ChunkSize chunk) path offset len = + Conduit.bracketP acquire IO.hClose seek + where + acquire = IO.openBinaryFile path IO.ReadMode + seek hd = do + liftIO (IO.hSeek hd IO.AbsoluteSeek offset) + go (fromIntegral len) hd + + go remainder hd + | remainder <= chunk = do + bs <- liftIO (BS.hGet hd remainder) + unless (BS.null bs) $ + Conduit.yield bs + -- + | otherwise = do + bs <- liftIO (BS.hGet hd chunk) + + unless (BS.null bs) $ do + Conduit.yield bs + go (remainder - chunk) hd + +-- | An opaque request body containing a 'SHA256' hash. +data HashedBody + = HashedStream (Digest SHA256) !Integer (ConduitM () ByteString (ResourceT IO) ()) + | HashedBytes (Digest SHA256) ByteString + +instance Show HashedBody where + show = \case + HashedStream h n _ -> str "HashedStream" h n + HashedBytes h x -> str "HashedBody" h (BS.length x) + where + str c h n = + BS8.unpack . toBS $ + c + <> " { sha256 = " + <> build (Bytes.encodeBase16 h) + <> ", length = " + <> build n + +instance IsString HashedBody where + fromString = toHashed + +sha256Base16 :: HashedBody -> ByteString +sha256Base16 = + Bytes.encodeBase16 . \case + HashedStream h _ _ -> h + HashedBytes h _ -> h + +-- | Construct a 'HashedBody' from a 'FilePath', calculating the 'SHA256' hash +-- and file size. +-- +-- /Note:/ While this function will perform in constant space, it will enumerate the +-- entirety of the file contents /twice/. Firstly to calculate the SHA256 and +-- lastly to stream the contents to the socket during sending. +-- +-- /See:/ 'ToHashedBody'. +hashedFile :: + MonadIO m => + -- | The file path to read. + FilePath -> + m HashedBody +hashedFile path = + liftIO $ + HashedStream + <$> runResourceT (Conduit.Binary.sourceFile path `Conduit.connect` Crypto.sinkSHA256) + <*> getFileSize path + <*> pure (Conduit.Binary.sourceFile path) + +-- | Construct a 'HashedBody' from a 'FilePath', specifying the range of bytes +-- to read. This can be useful for constructing multiple requests from a single +-- file, say for S3 multipart uploads. +-- +-- /See:/ 'hashedFile', 'Conduit.sourceFileRange'. +hashedFileRange :: + MonadIO m => + -- | The file path to read. + FilePath -> + -- | The byte offset at which to start reading. + Integer -> + -- | The maximum number of bytes to read. + Integer -> + m HashedBody +hashedFileRange path offset len = do + size <- getFileSize path + let bytes = min len (size - offset) + sourceFileRange = + Conduit.Binary.sourceFileRange path (Just offset) (Just len) + digest <- + liftIO . runResourceT $ Conduit.connect sourceFileRange Crypto.sinkSHA256 + pure $ HashedStream digest bytes sourceFileRange + +-- | Construct a 'HashedBody' from a 'Source', manually specifying the 'SHA256' +-- hash and file size. It's left up to the caller to calculate these correctly, +-- otherwise AWS will return signing errors. +-- +-- /See:/ 'ToHashedBody'. +hashedBody :: + -- | A SHA256 hash of the file contents. + Crypto.Digest Crypto.SHA256 -> + -- | The size of the stream in bytes. + Integer -> + ConduitM () ByteString (ResourceT IO) () -> + HashedBody +hashedBody = HashedStream + +-- | Invariant: only services that support /both/ standard and +-- chunked signing expose 'RequestBody' as a parameter. +data RequestBody + = -- | Currently S3 only, see 'ChunkedBody' for details. + Chunked ChunkedBody + | Hashed HashedBody + deriving stock (Show) + +instance IsString RequestBody where + fromString = Hashed . fromString + +md5Base64 :: RequestBody -> Maybe ByteString +md5Base64 = \case + Hashed (HashedBytes _ x) -> Just (Bytes.encodeBase64 (Crypto.hashMD5 x)) + _ -> Nothing + +isStreaming :: RequestBody -> Bool +isStreaming = \case + Hashed (HashedStream {}) -> True + _ -> False + +toRequestBody :: RequestBody -> Client.RequestBody +toRequestBody = \case + Chunked ChunkedBody {body} -> Client.Conduit.requestBodySourceChunked body + Hashed x -> case x of + HashedStream _ n f -> Client.Conduit.requestBodySource (fromIntegral n) f + HashedBytes _ b -> Client.RequestBodyBS b + +contentLength :: RequestBody -> Integer +contentLength = \case + Chunked ChunkedBody {length} -> length + Hashed x -> case x of + HashedStream _ n _ -> n + HashedBytes _ b -> fromIntegral (BS.length b) + +-- | Anything that can be safely converted to a 'HashedBody'. +class ToHashedBody a where + -- | Convert a value to a hashed request body. + toHashed :: a -> HashedBody + +instance ToHashedBody ByteString where + toHashed x = HashedBytes (Crypto.hash x) x + +instance ToHashedBody HashedBody where + toHashed = id + +instance ToHashedBody String where + toHashed = toHashed . LBS8.pack + +instance ToHashedBody ByteStringLazy where + toHashed = toHashed . toBS + +instance ToHashedBody Text where + toHashed = toHashed . Text.encodeUtf8 + +instance ToHashedBody TextLazy where + toHashed = toHashed . LText.encodeUtf8 + +instance ToHashedBody Aeson.Value where + toHashed = toHashed . Aeson.encode + +instance ToHashedBody XML.Element where + toHashed = toHashed . encodeXML + +instance ToHashedBody QueryString where + toHashed = toHashed . toBS + +#if MIN_VERSION_aeson(2,0,0) +instance ToHashedBody (KeyMap Aeson.Value) where + toHashed = toHashed . Aeson.Object +#else +instance ToHashedBody (HashMap Text Aeson.Value) where + toHashed = toHashed . Aeson.Object +#endif + +-- | Anything that can be converted to a streaming request 'Body'. +class ToBody a where + -- | Convert a value to a request body. + toBody :: a -> RequestBody + default toBody :: ToHashedBody a => a -> RequestBody + toBody = Hashed . toHashed + +instance ToBody RequestBody where + toBody = id + +instance ToBody HashedBody where + toBody = Hashed + +instance ToBody ChunkedBody where + toBody = Chunked + +instance ToHashedBody a => ToBody (Maybe a) where + toBody = Hashed . maybe (toHashed BS.empty) toHashed + +instance ToBody String + +instance ToBody ByteStringLazy + +instance ToBody ByteString + +instance ToBody Text + +instance ToBody TextLazy + +#if MIN_VERSION_aeson(2,0,0) +instance ToBody (KeyMap Aeson.Value) +#else +instance ToBody (HashMap Text Aeson.Value) +#endif + +instance ToBody Aeson.Value + +instance ToBody XML.Element + +instance ToBody QueryString diff --git a/src/Amazonka/Data/ByteString.hs b/src/Amazonka/Data/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/ByteString.hs @@ -0,0 +1,76 @@ +-- + +-- | +-- Module : Amazonka.Data.ByteString +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.ByteString + ( -- * ByteString + ByteString, + ByteStringLazy, + ToByteString (..), + showBS, + stripBS, + ) +where + +import Amazonka.Data.Text +import Amazonka.Prelude +import qualified Data.ByteString.Builder as Build +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI +import qualified Data.Char as Char +import qualified Data.Text.Encoding as Text +import qualified Network.HTTP.Types as HTTP +import qualified Numeric + +showBS :: ToByteString a => a -> String +showBS = BS8.unpack . toBS + +stripBS :: ByteString -> ByteString +stripBS = BS8.dropWhile Char.isSpace . fst . BS8.spanEnd Char.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 ByteStringBuilder where + toBS = toBS . Build.toLazyByteString + +instance ToByteString ByteStringLazy 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 . ($ "") . Numeric.showFFloat Nothing + +instance ToByteString HTTP.StdMethod where + toBS = HTTP.renderStdMethod + +instance ToByteString UTCTime where + toBS = BS8.pack . show + +instance ToByteString a => ToByteString (CI a) where + toBS = toBS . CI.original diff --git a/src/Amazonka/Data/Headers.hs b/src/Amazonka/Data/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/Headers.hs @@ -0,0 +1,156 @@ +-- | +-- Module : Amazonka.Data.Headers +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.Headers + ( module Amazonka.Data.Headers, + HeaderName, + Header, + HTTP.hContentType, + ) +where + +import Amazonka.Data.ByteString +import Amazonka.Data.Text +import Amazonka.Prelude +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Network.HTTP.Types (Header, HeaderName, ResponseHeaders) +import qualified Network.HTTP.Types as HTTP + +infixl 7 .#, .#? + +-- FIXME: This whole toText/fromText shit is just stupid. +(.#) :: 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] + +instance (ToByteString k, ToByteString v) => ToHeaders (HashMap k v) where + toHeaders = map (bimap (CI.mk . toBS) toBS) . HashMap.toList + +class ToHeader a where + toHeader :: HeaderName -> a -> [Header] + default toHeader :: ToText a => HeaderName -> a -> [Header] + toHeader k = toHeader k . toText + +instance ToHeader Int + +instance ToHeader Integer + +instance ToHeader Natural + +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) + +instance ToText a => ToHeader [a] where + toHeader k vs = case vs of + [] -> [] + _ -> toHeader k . Text.intercalate "," $ map toText vs + +instance (ToByteString k, ToByteString v) => ToHeader (HashMap k v) where + toHeader p = map (bimap k v) . HashMap.toList + where + k = mappend p . CI.mk . toBS + v = toBS + +parseHeadersMap :: + FromText a => + ByteString -> + ResponseHeaders -> + Either String (HashMap Text a) +parseHeadersMap p = fmap HashMap.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 + +hHost :: HeaderName +hHost = "Host" + +hExpect :: HeaderName +hExpect = "Expect" + +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" + +hAMZDecodedContentLength :: HeaderName +hAMZDecodedContentLength = "X-Amz-Decoded-Content-Length" + +hTransferEncoding :: HeaderName +hTransferEncoding = "Transfer-Encoding" + +hFormEncoded :: ByteString +hFormEncoded = "application/x-www-form-urlencoded; charset=utf-8" diff --git a/src/Amazonka/Data/JSON.hs b/src/Amazonka/Data/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/JSON.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Amazonka.Data.JSON +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.JSON + ( -- * FromJSON + Aeson.FromJSON (..), + Aeson.FromJSONKey (..), + parseJSONText, + Aeson.eitherDecode, + Aeson.eitherDecode', + + -- ** Parser a + Aeson.withObject, + (Aeson..:), + (Aeson..:?), + (Aeson..!=), + + -- ** Either String a + eitherParseJSON, + (.:>), + (.?>), + + -- * ToJSON + Aeson.ToJSON (..), + Aeson.ToJSONKey (..), + toJSONText, + Aeson.Value (Object), + Aeson.object, + (Aeson..=), + ) +where + +import Amazonka.Data.Text +import Amazonka.Prelude +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson.Types + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Key (Key) +#else +import qualified Data.HashMap.Strict as KM +type Key = Text +#endif + +parseJSONText :: FromText a => String -> Aeson.Value -> Aeson.Types.Parser a +parseJSONText n = Aeson.withText n (either fail pure . fromText) + +toJSONText :: ToText a => a -> Aeson.Value +toJSONText = Aeson.String . toText + +eitherParseJSON :: Aeson.FromJSON a => Aeson.Object -> Either String a +eitherParseJSON = Aeson.Types.parseEither Aeson.parseJSON . Aeson.Object + +(.:>) :: Aeson.FromJSON a => Aeson.Object -> Key -> Either String a +(.:>) o k = + case KM.lookup k o of + Nothing -> Left $ "key " ++ show k ++ " not present" + Just v -> Aeson.Types.parseEither Aeson.parseJSON v + +(.?>) :: Aeson.FromJSON a => Aeson.Object -> Key -> Either String (Maybe a) +(.?>) o k = + case KM.lookup k o of + Nothing -> Right Nothing + Just v -> Aeson.Types.parseEither Aeson.parseJSON v diff --git a/src/Amazonka/Data/Log.hs b/src/Amazonka/Data/Log.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/Log.hs @@ -0,0 +1,184 @@ +-- | +-- Module : Amazonka.Data.Log +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.Log where + +import Amazonka.Data.ByteString +import Amazonka.Data.Headers +import Amazonka.Data.Path +import Amazonka.Data.Query +import Amazonka.Data.Text +import Amazonka.Prelude +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Build +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI +import qualified Data.List as List +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 qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Types as HTTP +import qualified Numeric + +class ToLog a where + -- | Convert a value to a loggable builder. + build :: a -> ByteStringBuilder + +instance ToLog ByteStringBuilder where + build = id + +instance ToLog ByteStringLazy 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 . ($ "") . Numeric.showFFloat Nothing + +instance ToLog Double where + build = build . ($ "") . Numeric.showFFloat Nothing + +instance ToLog Text where + build = build . Text.encodeUtf8 + +instance ToLog TextLazy where + build = build . LText.encodeUtf8 + +instance ToLog Char where + build = build . Text.singleton + +instance ToLog [Char] where + build = build . LText.pack + +instance ToLog HTTP.StdMethod where + build = build . HTTP.renderStdMethod + +instance ToLog QueryString where + build = build . toBS + +instance ToLog EscapedPath where + build = build . toBS + +-- | Intercalate a list of 'ByteStringBuilder's with newlines. +buildLines :: [ByteStringBuilder] -> ByteStringBuilder +buildLines = mconcat . List.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 HTTP.Status where + build x = build (HTTP.statusCode x) <> " " <> build (HTTP.statusMessage x) + +instance ToLog [HTTP.Header] where + build = + mconcat + . List.intersperse "; " + . map (\(k, v) -> build k <> ": " <> build v) + +instance ToLog HTTP.HttpVersion where + build HTTP.HttpVersion {httpMajor, httpMinor} = + "HTTP/" + <> build httpMajor + <> build '.' + <> build httpMinor + +instance ToLog Client.RequestBody where + build = \case + Client.RequestBodyBuilder n _ -> " build n <> ">" + Client.RequestBodyStream n _ -> " build n <> ">" + Client.RequestBodyLBS lbs + | n <= 4096 -> build lbs + | otherwise -> " build n <> ">" + where + n = LBS.length lbs + Client.RequestBodyBS bs + | n <= 4096 -> build bs + | otherwise -> " build n <> ">" + where + n = BS.length bs + _ -> " " + +instance ToLog Client.HttpException where + build x = "[HttpException] {\n" <> build (show x) <> "\n}" + +instance ToLog Client.HttpExceptionContent where + build x = "[HttpExceptionContent] {\n" <> build (show x) <> "\n}" + +instance ToLog Client.Request where + build x = + buildLines + [ "[Client Request] {", + " host = " <> build (Client.host x) <> ":" <> build (Client.port x), + " secure = " <> build (Client.secure x), + " method = " <> build (Client.method x), + " target = " <> build target, + " timeout = " <> build (show (Client.responseTimeout x)), + " redirects = " <> build (Client.redirectCount x), + " path = " <> build (Client.path x), + " query = " <> build (Client.queryString x), + " headers = " <> build (Client.requestHeaders x), + " body = " <> build (Client.requestBody x), + "}" + ] + where + target = hAMZTarget `lookup` Client.requestHeaders x + +instance ToLog (Client.Response a) where + build x = + buildLines + [ "[Client Response] {", + " status = " <> build (Client.responseStatus x), + " headers = " <> build (Client.responseHeaders x), + "}" + ] diff --git a/src/Amazonka/Data/Path.hs b/src/Amazonka/Data/Path.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/Path.hs @@ -0,0 +1,111 @@ +-- | +-- Module : Amazonka.Data.Path +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.Path + ( -- * Path Types + Path (..), + RawPath, + EscapedPath, + TwiceEscapedPath, + + -- * Constructing Paths + ToPath (..), + rawPath, + + -- * Manipulating Paths + escapePath, + escapePathTwice, + collapsePath, + ) +where + +import Amazonka.Data.ByteString +import Amazonka.Data.Text +import Amazonka.Prelude +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Network.HTTP.Types.URI as URI + +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 . strip . BS8.split sep . toPath + where + strip (x : xs) + | BS.null x = xs + strip xs = xs + +data Encoding = NoEncoding | Percent + deriving stock (Eq, Show) + +data Path :: Encoding -> Type where + Raw :: [ByteString] -> Path 'NoEncoding + Encoded :: [ByteString] -> Path 'Percent + +deriving stock instance Show (Path a) + +deriving stock instance Eq (Path a) + +type RawPath = Path 'NoEncoding + +type EscapedPath = Path 'Percent + +-- | Used in SigV4 +newtype TwiceEscapedPath = TwiceEscapedPath (Path 'Percent) + deriving newtype (Eq, Show, ToByteString) + +instance Semigroup RawPath where + Raw xs <> Raw ys = Raw (xs ++ ys) + +instance Monoid RawPath where + mempty = Raw [] + mappend = (<>) + +instance ToByteString EscapedPath where + toBS (Encoded []) = slash + toBS (Encoded xs) = slash <> BS8.intercalate slash xs + +escapePath :: Path a -> EscapedPath +escapePath (Raw xs) = Encoded (map (URI.urlEncode True) xs) +escapePath (Encoded xs) = Encoded xs + +-- | Escape a path twice. Used when computing the SigV4 canonical path. +escapePathTwice :: Path a -> TwiceEscapedPath +escapePathTwice p = TwiceEscapedPath $ + Encoded $ case p of + Raw xs -> map (URI.urlEncode True . URI.urlEncode True) xs + Encoded xs -> map (URI.urlEncode True) 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/Amazonka/Data/Query.hs b/src/Amazonka/Data/Query.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/Query.hs @@ -0,0 +1,158 @@ +-- | +-- Module : Amazonka.Data.Query +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.Query where + +import Amazonka.Data.ByteString +import Amazonka.Data.Text +import Amazonka.Prelude +import qualified Data.ByteString.Builder as Build +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import qualified Data.Text.Encoding as Text +import qualified Network.HTTP.Types.URI as URI + +-- | Structured representation of a query string. +-- +-- Some operations (e.g., [sqs:CreateQueue](https://docs.aws.amazon.com/AWSSimpleQueueService/latest/APIReference/API_CreateQueue.html)) +-- use query parameters to pass structured data like lists and maps, +-- which is why this type is more complicatated than the +-- @[(ByteString, Maybe ByteString)]@ from @http-types@ that you may +-- have expected here. +data QueryString + = QList [QueryString] + | QPair ByteString QueryString + | QValue (Maybe ByteString) + deriving stock (Eq, Show) + +instance Semigroup QueryString where + 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 Monoid QueryString where + mempty = QList [] + mappend = (<>) + +instance IsString QueryString where + fromString = parseQueryString . fromString + {-# INLINE fromString #-} + +parseQueryString :: ByteString -> QueryString +parseQueryString bs + | BS8.null bs = mempty + | otherwise = + QList (map breakPair . filter (not . BS8.null) $ BS8.split '&' bs) + where + breakPair x = + case BS8.break (== '=') x of + ("", "") -> mempty + ("", v) -> stripValue v + (k, v) -> QPair (URI.urlDecode True k) (stripValue v) + + stripValue :: ByteString -> QueryString + stripValue x = + case x of + "" -> QValue Nothing + "=" -> QValue Nothing + _ -> QValue (Just (URI.urlDecode True $ BS8.drop 1 x)) + +-- FIXME: use Builder +instance ToByteString QueryString where + toBS = LBS.toStrict . Build.toLazyByteString . cat . List.sort . enc Nothing + where + enc :: Maybe ByteString -> QueryString -> [ByteString] + enc p = \case + QList xs -> concatMap (enc p) xs + QPair (URI.urlEncode True -> k) x + | Just n <- p -> enc (Just (n <> kdelim <> k)) x -- .key + | otherwise -> enc (Just k) x -- key + QValue (Just (URI.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] -> ByteStringBuilder + 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 + +toQueryMap :: + (ToQuery k, ToQuery v) => + ByteString -> + ByteString -> + ByteString -> + HashMap k v -> + QueryString +toQueryMap e k v = toQueryList e . map f . HashMap.toList + where + f (x, y) = QList [k =: toQuery x, v =: toQuery y] + +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/Amazonka/Data/Sensitive.hs b/src/Amazonka/Data/Sensitive.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/Sensitive.hs @@ -0,0 +1,50 @@ +-- | +-- Module : Amazonka.Data.Sensitive +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.Sensitive where + +import Amazonka.Core.Lens.Internal (iso) +import Amazonka.Data.Body +import Amazonka.Data.ByteString +import Amazonka.Data.Headers +import Amazonka.Data.JSON +import Amazonka.Data.Log +import Amazonka.Data.Query +import Amazonka.Data.Text +import Amazonka.Data.XML +import Amazonka.Prelude + +-- | /Note/: read . show /= isomorphic +newtype Sensitive a = Sensitive {fromSensitive :: a} + deriving stock (Eq, Ord, Generic, Functor) + deriving newtype + ( IsString, + Semigroup, + Monoid, + ToByteString, + FromText, + ToText, + FromXML, + ToXML, + ToQuery, + ToJSON, + FromJSON, + ToHeader, + ToBody, + Hashable, + NFData, + IsList + ) + +instance Show (Sensitive a) where + show = const "******" + +instance ToLog (Sensitive a) where + build = const "******" + +_Sensitive :: Iso' (Sensitive a) a +_Sensitive = iso fromSensitive Sensitive diff --git a/src/Amazonka/Data/Text.hs b/src/Amazonka/Data/Text.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/Text.hs @@ -0,0 +1,138 @@ +-- | +-- Module : Amazonka.Data.Text +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.Text + ( Text, + + -- * Deserialisation + FromText (..), + + -- * Serialisation + ToText (..), + toTextCI, + showText, + ) +where + +import qualified Amazonka.Bytes as Bytes +import qualified Amazonka.Crypto as Crypto +import Amazonka.Prelude +import qualified Data.Attoparsec.Text as A +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.CaseInsensitive as CI +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.Builder as Build +import qualified Data.Text.Lazy.Builder.Int as Build +import qualified Data.Text.Lazy.Builder.Scientific as Build +import qualified Network.HTTP.Types as HTTP +import qualified Numeric + +class FromText a where + fromText :: Text -> Either String a + +instance FromText Text where + fromText = pure + +instance FromText String where + fromText = pure . Text.unpack + +instance FromText ByteString where + fromText = pure . Text.encodeUtf8 + +instance (CI.FoldCase a, FromText a) => FromText (CI a) where + fromText = fmap CI.mk . fromText + +instance FromText Char where + fromText = A.parseOnly (A.anyChar <* A.endOfInput) + +instance FromText Int where + fromText = A.parseOnly (A.signed A.decimal <* A.endOfInput) + +instance FromText Int64 where + fromText = A.parseOnly (A.signed A.decimal <* A.endOfInput) + +instance FromText Integer where + fromText = A.parseOnly (A.signed A.decimal <* A.endOfInput) + +instance FromText Scientific where + fromText = A.parseOnly (A.signed A.scientific <* A.endOfInput) + +instance FromText Natural where + fromText = A.parseOnly (A.decimal <* A.endOfInput) + +instance FromText Double where + fromText = A.parseOnly (A.signed A.rational <* A.endOfInput) + +instance FromText Bool where + fromText text = + case CI.mk text of + "true" -> pure True + "false" -> pure False + other -> Left ("Failure parsing Bool from " ++ show other ++ ".") + +instance FromText HTTP.StdMethod where + fromText text = + case HTTP.parseMethod (Text.encodeUtf8 text) of + Left err -> Left (BS8.unpack err) + Right ok -> pure ok + +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 . ($ "") . Numeric.showFFloat Nothing + +instance ToText HTTP.StdMethod where + toText = toText . HTTP.renderStdMethod + +instance ToText (Crypto.Digest a) where + toText = toText . Bytes.encodeBase16 + +instance ToText Bool where + toText True = "true" + toText False = "false" + +shortText :: TextBuilder -> Text +shortText = LText.toStrict . Build.toLazyTextWith 32 + +toTextCI :: ToText a => a -> CI Text +toTextCI = CI.mk . toText diff --git a/src/Amazonka/Data/Time.hs b/src/Amazonka/Data/Time.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/Time.hs @@ -0,0 +1,251 @@ +-- | +-- Module : Amazonka.Data.Time +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.Time + ( -- * Time + Format (..), + Time (..), + _Time, + + -- ** Formats + UTCTime, + RFC822, + ISO8601, + BasicTime, + AWSTime, + POSIX, + ) +where + +import Amazonka.Core.Lens.Internal (iso) +import Amazonka.Data.ByteString +import Amazonka.Data.JSON +import Amazonka.Data.Query +import Amazonka.Data.Text +import Amazonka.Data.XML +import Amazonka.Prelude +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Attoparsec.Text as A +import qualified Data.Attoparsec.Text as AText +import qualified Data.ByteString.Char8 as BS +import qualified Data.Scientific as Scientific +import qualified Data.Text as Text +import qualified Data.Time as Time +import Data.Time.Clock.POSIX +import Data.Time.Format (defaultTimeLocale, formatTime) + +data Format + = RFC822Format + | ISO8601Format + | BasicFormat + | AWSFormat + | POSIXFormat + deriving stock (Eq, Read, Show, Generic) + +newtype Time (a :: Format) = Time {fromTime :: UTCTime} + deriving stock (Show, Read, Eq, Ord, Generic) + deriving newtype (NFData) + +instance Hashable (Time a) where + hashWithSalt salt (Time (Time.UTCTime (Time.ModifiedJulianDay d) t)) = + salt + `hashWithSalt` d + `hashWithSalt` toRational t + +_Time :: Iso' (Time a) UTCTime +_Time = iso fromTime Time + +convert :: Time a -> Time b +convert = coerce + +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 :: proxy a -> String + +instance TimeFormat RFC822 where + format _ = "%a, %d %b %Y %H:%M:%S %Z" + +instance TimeFormat ISO8601 where + format _ = "%FT%XZ" + +instance TimeFormat BasicTime where + format _ = "%Y%m%d" + +instance TimeFormat AWSTime where + format _ = "%Y%m%dT%H%M%SZ" + +instance FromText (Time fmt) where + fromText = A.parseOnly ((parseUnixTimestamp <|> parseFormattedTime) <* A.endOfInput) + +parseFormattedTime :: A.Parser (Time a) +parseFormattedTime = do + s <- Text.unpack <$> AText.takeText + + let parse :: String -> A.Parser (Time a) + parse fmt = + case Time.parseTimeM True defaultTimeLocale fmt s of + Just x -> pure (Time x) + Nothing -> + fail + ( "Unable to parse Time format " + ++ show fmt + ++ " from " + ++ show s + ) + + parse (format (Proxy @RFC822)) + <|> parse (format (Proxy @ISO8601)) + <|> parse (format (Proxy @BasicTime)) + <|> parse (format (Proxy @AWSTime)) + -- Deprecated ISO8601 format exhibited in the AWS-supplied examples. + <|> parse "%FT%X%Q%Z" + -- Exhaustive Failure + <|> fail ("Failure parsing Time from value: " ++ show s) + +parseUnixTimestamp :: A.Parser (Time a) +parseUnixTimestamp = + Time . posixSecondsToUTCTime . realToFrac + <$> AText.double + <* AText.endOfInput + <|> fail "Failure parsing Unix Timestamp" + +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 + (format (Proxy @(Time a))) + -- Convert `t` to a GMT `ZonedTime`, because otherwise the + -- `FormatTime` instance for `UTCTime` converts to UTC `ZonedTime` + -- for us. While they are the same offset, a UTC `ZonedTime` emits + -- `UTC` instead of `GMT` when formatted by `RFC822`'s + -- `TimeFormat`, which is not a valid `zone` in RFC 822's grammar. + (Time.utcToZonedTime (read "GMT") t) + +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 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" + +-- This is a somewhat unfortunate hack to support the bizzare apigateway +-- occurence of returning ISO8601 or POSIX timestamps in unknown scenarios. +-- +-- See: https://github.com/brendanhay/amazonka/issues/291 +instance FromJSON POSIX where + parseJSON o = fmap convert (str o) <|> num o + where + str :: Value -> Aeson.Parser ISO8601 + str = parseJSON + + num :: Value -> Aeson.Parser POSIX + num = + Aeson.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 ToQuery POSIX where + toQuery (Time t) = toQuery (truncate (utcTimeToPOSIXSeconds t) :: Integer) + +instance ToXML RFC822 where + toXML = toXMLText + +instance ToXML ISO8601 where + toXML = toXMLText + +instance ToXML AWSTime where + toXML = toXMLText + +instance ToXML BasicTime 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) = + Aeson.Number $ + Scientific.scientific (truncate (utcTimeToPOSIXSeconds t) :: Integer) 0 diff --git a/src/Amazonka/Data/XML.hs b/src/Amazonka/Data/XML.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Data/XML.hs @@ -0,0 +1,312 @@ +-- | +-- Module : Amazonka.Data.XML +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Data.XML where + +import Amazonka.Data.ByteString +import Amazonka.Data.Text +import Amazonka.Prelude +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Conduit as Conduit +import qualified Data.Conduit.Lazy as Conduit.Lazy +import qualified Data.Conduit.List as Conduit.List +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List.NonEmpty as NonEmpty +import Data.XML.Types (Event (..)) +import System.IO.Unsafe (unsafePerformIO) +import Text.XML +import qualified Text.XML.Stream.Render as XML.Stream +import qualified Text.XML.Unresolved as XML.Unresolved + +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 + +(@@=) :: ToText a => Name -> a -> XML +n @@= x = XAttr n (toText x) + +decodeXML :: FromXML a => ByteStringLazy -> Either String a +decodeXML lbs = + bimap show documentRoot (parseLBS def lbs) + >>= parseXML . childrenOf + +-- The following is taken from xml-conduit.Text.XML which uses +-- unsafePerformIO anyway, with the following caveat: +-- 'not generally safe, but we know that runResourceT +-- will not deallocate any of the resources being used +-- by the process.' +encodeXML :: ToElement a => a -> ByteStringLazy +encodeXML x = + LBS.fromChunks . unsafePerformIO . Conduit.Lazy.lazyConsume $ + Conduit.List.sourceList (XML.Unresolved.toEvents doc) + Conduit..| Conduit.List.map rename + Conduit..| XML.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 + +-- | Convert to an 'Element', only if the resulting element contains @> 0@ nodes. +maybeElement :: ToElement a => a -> Maybe Element +maybeElement x = + case toElement x of + e@(Element _ _ ns) + | null ns -> Nothing + | otherwise -> Just e + +-- | Provides a way to make the operators for ToXML instance +-- declaration be consistent WRT to single nodes or lists of nodes. +data XML + = XNull + | XAttr Name Text + | XOne Node + | XMany [(Name, Text)] [Node] + deriving stock (Show) + +instance Semigroup XML where + XNull <> XNull = XNull + a <> XNull = a + XNull <> b = b + a <> b = + XMany + (listXMLAttributes a <> listXMLAttributes b) + (listXMLNodes a <> listXMLNodes b) + +instance Monoid XML where + mempty = XNull + mappend = (<>) + +listXMLNodes :: XML -> [Node] +listXMLNodes = \case + XNull -> [] + XAttr {} -> [] + XOne n -> [n] + XMany _ ns -> ns + +listXMLAttributes :: XML -> [(Name, Text)] +listXMLAttributes = \case + XNull -> [] + XAttr n t -> [(n, t)] + XOne {} -> [] + XMany as _ -> as + +class ToXML a where + toXML :: a -> XML + +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 + +parseXMLMap :: + (Eq k, Hashable k, FromText k, FromXML v) => + Text -> + Text -> + Text -> + [Node] -> + Either String (HashMap k v) +parseXMLMap e k v = + fmap HashMap.fromList . traverse f . mapMaybe (childNodesOf e) + where + f ns = + (,) + <$> (ns .@ k >>= fromText) + <*> ns .@ v + +parseXMLList1 :: + FromXML a => + Text -> + [Node] -> + Either String (NonEmpty a) +parseXMLList1 n = parseXMLList n >=> parse + where + parse xs = + maybe + (Left $ "Error parsing empty List1 when expecting at least one element: " ++ show n) + Right + (NonEmpty.nonEmpty xs) + +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 (toXML -> x) = + Element n (fromList (listXMLAttributes x)) (listXMLNodes x) + +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 + +-- | Find a specific named NodeElement, at the current depth in the node tree. +-- +-- Fails if absent. +findElement :: Text -> [Node] -> Either String [Node] +findElement n ns = + missingElement n ns + . listToMaybe + $ mapMaybe (childNodesOf n) ns + +-- | Find the first specific named NodeElement, at any depth in the node tree. +-- +-- Fails if absent. +firstElement :: Text -> [Node] -> Either String [Node] +firstElement n ns = + missingElement n ns + . listToMaybe + $ mapMaybe go ns + where + go x = case x of + NodeElement e + | Just n == localName x -> Just (childrenOf e) + | otherwise -> listToMaybe (mapMaybe go (elementNodes e)) + _ -> Nothing + +childNodesOf :: Text -> Node -> Maybe [Node] +childNodesOf n x = case x of + NodeElement e + | Just n == localName x -> + Just (childrenOf e) + _ -> Nothing + +childrenOf :: Element -> [Node] +childrenOf e = elementNodes e <> map node (toList (elementAttributes e)) + where + node (k, v) = NodeElement (Element (name k) mempty [NodeContent v]) + + name k = + Name + { nameLocalName = fromMaybe "" (namePrefix k) <> ":" <> nameLocalName k, + nameNamespace = mempty, + namePrefix = mempty + } + +localName :: Node -> Maybe Text +localName = \case + NodeElement e -> Just (nameLocalName (elementName e)) + _ -> Nothing + +-- | An inefficient mechanism for retreiving the root +-- element name of an XML document. +rootElementName :: ByteStringLazy -> Maybe Text +rootElementName bs = + either + (const Nothing) + (Just . nameLocalName . elementName . documentRoot) + (parseLBS def bs) + +missingElement :: Text -> [Node] -> Maybe a -> Either String a +missingElement n ns = maybe (Left err) Right + where + err = + "unable to find element " + ++ show n + ++ " in nodes " + ++ show (mapMaybe localName ns) diff --git a/src/Amazonka/Endpoint.hs b/src/Amazonka/Endpoint.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Endpoint.hs @@ -0,0 +1,97 @@ +-- | +-- Module : Amazonka.Endpoint +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Endpoint + ( -- * Endpoint + setEndpoint, + defaultEndpoint, + ) +where + +import Amazonka.Data.ByteString +import Amazonka.Prelude +import Amazonka.Types +import qualified Data.CaseInsensitive as CI + +-- | A convenience function for overriding the 'Service' 'Endpoint'. +-- +-- /See:/ 'endpoint'. +setEndpoint :: + -- | Whether to use HTTPS (ie. SSL). + Bool -> + -- | The hostname to connect to. + ByteString -> + -- | The port number to connect to. + Int -> + -- | The service configuration to override. + Service -> + Service +setEndpoint secure host port s@Service {endpoint} = + s {endpoint = \r -> (endpoint r) {secure, host, port}} + +-- | Determine the full host address and credential scope +-- within the specified 'Region'. +defaultEndpoint :: Service -> Region -> Endpoint +defaultEndpoint Service {endpointPrefix = p} r = go (CI.mk p) + 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" + "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" + "waf" + | not china -> global "waf.amazonaws.com" + _other + | china -> region (p <> "." <> reg <> ".amazonaws.com.cn") + | otherwise -> region (p <> "." <> reg <> ".amazonaws.com") + + virginia = r == NorthVirginia + frankfurt = r == Frankfurt + china = r == Beijing + govcloud = r == GovCloudEast || r == GovCloudWest + + region host = + Endpoint + { host, + basePath = mempty, + secure = True, + port = 443, + scope = reg + } + + global host = + Endpoint + { host, + basePath = mempty, + secure = True, + port = 443, + scope = "us-east-1" + } + + reg = toBS r diff --git a/src/Amazonka/Error.hs b/src/Amazonka/Error.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Error.hs @@ -0,0 +1,186 @@ +-- | +-- Module : Amazonka.Error +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Error where + +import Amazonka.Core.Lens.Internal (Choice, Fold, Optic', filtered) +import Amazonka.Data +import Amazonka.Prelude +import Amazonka.Types +import qualified Amazonka.Types as ServiceError (ServiceError (..)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson.Types +import qualified Data.ByteString.Lazy as LBS +import Data.Either (fromRight) +import qualified Data.Text as Text +import qualified Network.HTTP.Client as Client +import Network.HTTP.Types.Status (Status (..)) + +-- | Provides a generalised prism for catching a specific service error +-- identified by the opaque service abbreviation and error code. +-- +-- This can be used if the generated error prisms provided by +-- @Amazonka..Types@ do not cover all the thrown error codes. +-- For example to define a new error prism: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Amazonka.S3 (ServiceError, s3) +-- > +-- > _NoSuchBucketPolicy :: AsError a => Fold a ServiceError +-- > _NoSuchBucketPolicy = _MatchServiceError s3 "NoSuchBucketPolicy" +-- +-- With example usage being: +-- +-- >>> import Control.Exception.Lens (trying) +-- >>> :t trying _NoSuchBucketPolicy +-- MonadCatch m => m a -> m (Either ServiceError a) +_MatchServiceError :: + AsError a => + Service -> + ErrorCode -> + Fold a ServiceError +_MatchServiceError s c = _ServiceError . hasService s . hasCode c + +statusSuccess :: Status -> Bool +statusSuccess (statusCode -> n) = n >= 200 && n < 300 || n == 304 + +_HttpStatus :: AsError a => Traversal' a Status +_HttpStatus = _Error . f + where + f g = \case + TransportError (Client.HttpExceptionRequest rq (Client.StatusCodeException rs b)) -> + (\x -> TransportError (Client.HttpExceptionRequest rq (Client.StatusCodeException (rs {Client.responseStatus = x}) b))) + <$> g (Client.responseStatus rs) + -- + TransportError e -> + pure (TransportError e) + -- + SerializeError (SerializeError' a s b e) -> + (\x -> SerializeError (SerializeError' a x b e)) <$> g s + -- + ServiceError e@ServiceError' {status} -> + (\x -> ServiceError (e {status = x})) <$> g status + +hasService :: + (Applicative f, Choice p) => + Service -> + Optic' p f ServiceError ServiceError +hasService Service {abbrev} = filtered ((abbrev ==) . ServiceError.abbrev) + +hasStatus :: + (Applicative f, Choice p) => + Int -> + Optic' p f ServiceError ServiceError +hasStatus n = filtered ((n ==) . fromEnum . ServiceError.status) + +hasCode :: + (Applicative f, Choice p) => + ErrorCode -> + Optic' p f ServiceError ServiceError +hasCode c = filtered ((c ==) . ServiceError.code) + +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) + +getRequestId :: [Header] -> Maybe RequestId +getRequestId h + | Right hAMZ <- h .# hAMZRequestId = Just hAMZ + | Right hAMZN <- h .# hAMZNRequestId = Just hAMZN + | otherwise = Nothing + +getErrorCode :: Status -> [Header] -> ErrorCode +getErrorCode s h = + case h .# hAMZNErrorType of + Left _ -> newErrorCode (toText (statusMessage s)) + Right x -> newErrorCode code + where + -- For headers only, botocore takes everything in the header + -- value before a colon: + -- https://github.com/boto/botocore/blob/fec0e5bd5e4a9d7dcadb36198423e61437294fe6/botocore/parsers.py#L1006-L1015 + (code, _) = Text.break (== ':') x + +parseJSONError :: + Abbrev -> + Status -> + [Header] -> + ByteStringLazy -> + Error +parseJSONError a s h bs = + decodeError a s h bs (parse bs) + where + parse = + eitherDecode' + >=> Aeson.Types.parseEither (Aeson.withObject "JSONError" go) + + go o = do + e <- (Just <$> o .: "__type") <|> o .:? "code" + m <- msg e o + + pure (serviceError a s h e m Nothing) + + msg c o = + if c == Just "RequestEntityTooLarge" + then pure (Just "Request body must be less than 1 MB") + else + Just <$> o .: "message" + <|> o .:? "Message" + +parseXMLError :: + Abbrev -> + Status -> + [Header] -> + ByteStringLazy -> + Error +parseXMLError a s h bs = decodeError a s h bs (go <$> decodeXML bs) + where + go x = + serviceError + a + s + h + (code x) + (may' (firstElement "Message" x)) + (may' (firstElement "RequestId" x) <|> may' (firstElement "RequestID" x)) + + code x = fromRight root $ parseXML =<< firstElement "Code" x + + root = newErrorCode <$> rootElementName bs + + may' x = either (const Nothing) Just $ parseXML =<< x + +parseRESTError :: + Abbrev -> + Status -> + [Header] -> + a -> + Error +parseRESTError a s h _ = + ServiceError (serviceError a s h Nothing Nothing Nothing) + +decodeError :: + Abbrev -> + Status -> + [Header] -> + ByteStringLazy -> + Either String ServiceError -> + Error +decodeError a s h bs e + | LBS.null bs = parseRESTError a s h bs + | otherwise = + either + (SerializeError . SerializeError' a s (Just bs)) + ServiceError + e diff --git a/src/Amazonka/Pager.hs b/src/Amazonka/Pager.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Pager.hs @@ -0,0 +1,55 @@ +-- | +-- Module : Amazonka.Pager +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Pager + ( AWSPager (..), + AWSTruncated (..), + stop, + choice, + ) +where + +import Amazonka.Core.Lens.Internal (Getter, to) +import Amazonka.Data (ToText (..)) +import Amazonka.Prelude +import Amazonka.Types +import qualified Data.HashMap.Strict as HashMap + +-- | 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 -> AWSResponse 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 [a] where + truncated = not . null + +instance AWSTruncated (HashMap k v) where + truncated = not . HashMap.null + +instance {-# OVERLAPPABLE #-} AWSTruncated (Maybe a) where + truncated = isJust + +instance {-# OVERLAPS #-} AWSTruncated (Maybe Bool) where + truncated = fromMaybe False + +stop :: AWSTruncated a => a -> Bool +stop = not . truncated + +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/Amazonka/Prelude.hs b/src/Amazonka/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Prelude.hs @@ -0,0 +1,82 @@ +-- | +-- Module : Amazonka.Prelude +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- An intentionally limited set of prelude exports to control backward +-- compatibility and simplify code generation. +-- +-- Please consider long and hard before adding any addtional types exports to +-- this module - they should either be in pervasive use throughout the project +-- or have zero ambiguity. If you ever are forced to disambiguate at any point, +-- it's a bad export. +-- +-- Try and avoid any value, operator, or symbol exports, if possible. Most of +-- the ones here exist to ease legacy code-migration. +module Amazonka.Prelude + ( module Export, + TextLazy, + TextBuilder, + ByteStringLazy, + ByteStringBuilder, + ) +where + +import Control.Applicative as Export (Alternative ((<|>))) +import Control.DeepSeq as Export (NFData (rnf)) +import Control.Exception as Export (Exception, SomeException) +import Control.Lens as Export + ( Iso', + Lens', + Prism', + Setter', + Traversal', + ) +import Control.Monad as Export +import Control.Monad.IO.Class as Export (MonadIO (liftIO)) +import Control.Monad.Trans.Class as Export (MonadTrans (lift)) +import Control.Monad.Trans.Resource as Export (MonadResource) +import Data.Bifoldable as Export +import Data.Bifunctor as Export +import Data.Bitraversable as Export +import Data.ByteString as Export (ByteString) +import qualified Data.ByteString.Builder as ByteString.Builder +import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.CaseInsensitive as Export (CI) +import Data.Coerce as Export (Coercible, coerce) +import Data.Function as Export ((&)) +import Data.Functor as Export ((<&>)) +import Data.Functor.Identity as Export (Identity (..)) +import Data.HashMap.Strict as Export (HashMap) +import Data.HashSet as Export (HashSet) +import Data.Hashable as Export (Hashable (hash, hashWithSalt)) +import Data.Int as Export (Int16, Int32, Int64, Int8) +import Data.Kind as Export (Type) +import Data.List.NonEmpty as Export (NonEmpty ((:|))) +import Data.Maybe as Export +import Data.Monoid as Export (First) +import Data.Proxy as Export (Proxy (Proxy)) +import Data.Scientific as Export (Scientific) +import Data.String as Export (IsString (fromString)) +import Data.Text as Export (Text) +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.Builder as Text.Lazy.Builder +import Data.Time as Export (Day, DiffTime, NominalDiffTime, UTCTime) +import Data.Void as Export (Void) +import Data.Word as Export (Word16, Word32, Word64, Word8) +import GHC.Exts as Export (IsList (..)) +import GHC.Generics as Export (Generic) +import GHC.TypeLits as Export (KnownNat, KnownSymbol, Nat, Symbol) +import Numeric.Natural as Export (Natural) +import Prelude as Export + +type TextLazy = Text.Lazy.Text + +type TextBuilder = Text.Lazy.Builder.Builder + +type ByteStringLazy = ByteString.Lazy.ByteString + +type ByteStringBuilder = ByteString.Builder.Builder diff --git a/src/Amazonka/Request.hs b/src/Amazonka/Request.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Request.hs @@ -0,0 +1,207 @@ +-- | +-- Module : Amazonka.Request +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Request + ( -- * Requests + head', + delete, + get, + + -- ** Empty body + post, + put, + + -- ** Specialised body + patchBody, + patchJSON, + postXML, + postJSON, + postQuery, + postBody, + putXML, + putJSON, + putBody, + + -- ** Constructors + defaultRequest, + + -- ** Operation Plugins + contentMD5Header, + expectHeader, + glacierVersionHeader, + s3vhost, + + -- ** Lenses + clientRequestHeaders, + clientRequestQuery, + clientRequestURL, + ) +where + +import Amazonka.Core +import Amazonka.Data +import Amazonka.Prelude +import qualified Data.ByteString.Char8 as B8 +import qualified Network.HTTP.Client as Client +import Network.HTTP.Types (StdMethod (..)) +import qualified Network.HTTP.Types as HTTP +import Text.Regex.Posix + +type ToRequest a = (ToPath a, ToQuery a, ToHeaders a) + +head' :: ToRequest a => Service -> a -> Request a +head' s x = (get s x) {method = HEAD} + +delete :: ToRequest a => Service -> a -> Request a +delete s x = (get s x) {method = DELETE} + +get :: ToRequest a => Service -> a -> Request a +get = defaultRequest + +post :: ToRequest a => Service -> a -> Request a +post s x = (get s x) {method = POST} + +put :: ToRequest a => Service -> a -> Request a +put s x = (get s x) {method = PUT} + +patchBody :: (ToRequest a, ToBody a) => Service -> a -> Request a +patchBody s x = (putBody s x) {method = PATCH} + +patchJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a +patchJSON s x = (putJSON s x) {method = PATCH} + +postXML :: (ToRequest a, ToElement a) => Service -> a -> Request a +postXML s x = (putXML s x) {method = POST} + +postJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a +postJSON s x = (putJSON s x) {method = POST} + +postQuery :: ToRequest a => Service -> a -> Request a +postQuery service x = + Request + { service, + method = POST, + path = rawPath x, + query = mempty, + body = toBody (toQuery x), + headers = hdr hContentType hFormEncoded (toHeaders x) + } + +postBody :: (ToRequest a, ToBody a) => Service -> a -> Request a +postBody s x = (post s x) {body = toBody x} + +putXML :: (ToRequest a, ToElement a) => Service -> a -> Request a +putXML s x = (put s x) {body = maybe "" toBody (maybeElement x)} + +putJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a +putJSON s x = (put s x) {body = toBody (toJSON x)} + +putBody :: (ToRequest a, ToBody a) => Service -> a -> Request a +putBody s x = (put s x) {body = toBody x} + +defaultRequest :: ToRequest a => Service -> a -> Request a +defaultRequest service x = + Request + { service, + method = GET, + path = rawPath x, + query = toQuery x, + headers = toHeaders x, + body = "" + } + +clientRequestQuery :: Lens' ClientRequest ByteString +clientRequestQuery f x = + f (Client.queryString x) <&> \y -> x {Client.queryString = y} + +clientRequestHeaders :: Lens' ClientRequest HTTP.RequestHeaders +clientRequestHeaders f x = + f (Client.requestHeaders x) <&> \y -> x {Client.requestHeaders = y} + +clientRequestURL :: ClientRequest -> ByteString +clientRequestURL x = + scheme + <> toBS (Client.host x) + <> port (Client.port x) + <> toBS (Client.path x) + <> toBS (Client.queryString x) + where + scheme + | secure = "https://" + | otherwise = "http://" + + port = \case + 80 -> "" + 443 | secure -> "" + n -> ":" <> toBS n + + secure = Client.secure x + +contentMD5Header :: Request a -> Request a +contentMD5Header rq@Request {headers, body} + | isMissing, Just x <- maybeMD5 = rq {headers = hdr HTTP.hContentMD5 x headers} + | otherwise = rq + where + maybeMD5 = md5Base64 body + isMissing = isNothing (lookup HTTP.hContentMD5 headers) + +expectHeader :: Request a -> Request a +expectHeader rq@Request {headers} = + rq {headers = hdr hExpect "100-continue" headers} + +glacierVersionHeader :: ByteString -> Request a -> Request a +glacierVersionHeader version rq@Request {headers} = + rq {headers = hdr "x-amz-glacier-version" version headers} + +-- Rewrite a request to use virtual-hosted-style buckets where +-- possible and requested. +-- +-- Example: A request to endpoint "s3.region.amazonaws.com" with path +-- "/foo/bar" means "object bar in bucket foo". Rewrite it to endpoint +-- "foo.s3.region.amazonaws.com" and path "/bar". +-- +-- This is basically the logic in +-- https://github.com/boto/botocore/blob/04d1fae43b657952e49b21d16daa86378ddb4253/botocore/utils.py#L1922-L1941 +-- except that we can't tell if an endpoint has been overridden, as a +-- 'Request' contains a 'Service' after all overrides have been +-- applied. +-- +-- See: https://boto3.amazonaws.com/v1/documentation/api/1.9.42/guide/s3.html#changing-the-addressing-style +-- See: https://docs.aws.amazon.com/AmazonS3/latest/userguide/VirtualHosting.html +s3vhost :: Request a -> Request a +s3vhost + rq@Request + { path = path, + service = service@Service {endpoint, s3AddressingStyle} + } = case path of + Raw [] -> rq -- Impossible? + Raw (bucketName : p) -> + let bucketNameLen = B8.length bucketName + + -- Inspired by: + -- https://github.com/boto/botocore/blob/04d1fae43b657952e49b21d16daa86378ddb4253/botocore/utils.py#L1067 + rewritePossible + | '.' `B8.elem` bucketName = False + | bucketNameLen < 3 || bucketNameLen > 63 = False + | not $ bucketName =~ ("^[a-z0-9][a-z0-9\\-]*[a-z0-9]$" :: ByteString) = False + | otherwise = True + + doRewrite = case s3AddressingStyle of + S3AddressingStyleAuto -> rewritePossible + S3AddressingStylePath -> False + S3AddressingStyleVirtual -> True + + path' = Raw p + service' = + service + { endpoint = \r -> + let e@Endpoint {host} = endpoint r + in e {host = mconcat [bucketName, ".", host]} + } + in if doRewrite + then rq {path = path', service = service'} + else rq diff --git a/src/Amazonka/Response.hs b/src/Amazonka/Response.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Response.hs @@ -0,0 +1,177 @@ +-- | +-- Module : Amazonka.Response +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Functions contained in this module fully consume the body and thus close +-- the connection. This is needed to avoid hitting this issue: +-- . +-- +-- The only exception is 'receiveBody', which passes a streaming response +-- body to a callback and thus is not allowed to close the connection. Users +-- of streaming functions are advised to be careful and consume the response +-- body manually if they want the connection to be closed promptly. +-- +-- Note that using 'runResourceT' will always close the connection. +module Amazonka.Response + ( receiveNull, + receiveEmpty, + receiveXMLWrapper, + receiveXML, + receiveJSON, + receiveBytes, + receiveBody, + ) +where + +import Amazonka.Data +import Amazonka.Prelude hiding (error) +import Amazonka.Types +import qualified Control.Monad.Trans.Except as Except +import Control.Monad.Trans.Resource (liftResourceT) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.Conduit () +import qualified Data.Conduit as Conduit +import qualified Data.Conduit.Binary as Conduit.Binary +import Data.Functor (($>)) +import qualified Network.HTTP.Client as Client +import Network.HTTP.Types (ResponseHeaders) +import qualified Text.XML as XML + +receiveNull :: + MonadResource m => + AWSResponse a -> + (ByteStringLazy -> IO ByteStringLazy) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) +receiveNull rs _ = + stream $ \r _ _ _ -> + liftIO (Client.responseClose r) $> Right rs + +receiveEmpty :: + MonadResource m => + (Int -> ResponseHeaders -> () -> Either String (AWSResponse a)) -> + (ByteStringLazy -> IO ByteStringLazy) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) +receiveEmpty f _ = + stream $ \r s h _ -> + liftIO (Client.responseClose r) $> f s h () + +receiveXMLWrapper :: + MonadResource m => + Text -> + (Int -> ResponseHeaders -> [XML.Node] -> Either String (AWSResponse a)) -> + (ByteStringLazy -> IO ByteStringLazy) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) +receiveXMLWrapper n f = receiveXML (\s h x -> x .@ n >>= f s h) + +receiveXML :: + MonadResource m => + (Int -> ResponseHeaders -> [XML.Node] -> Either String (AWSResponse a)) -> + (ByteStringLazy -> IO ByteStringLazy) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) +receiveXML = deserialise decodeXML + +receiveJSON :: + MonadResource m => + (Int -> ResponseHeaders -> Aeson.Object -> Either String (AWSResponse a)) -> + (ByteStringLazy -> IO ByteStringLazy) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) +receiveJSON = deserialise Aeson.eitherDecode' + +receiveBytes :: + MonadResource m => + (Int -> ResponseHeaders -> ByteString -> Either String (AWSResponse a)) -> + (ByteStringLazy -> IO ByteStringLazy) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) +receiveBytes = deserialise (Right . LBS.toStrict) + +receiveBody :: + MonadResource m => + (Int -> ResponseHeaders -> ResponseBody -> Either String (AWSResponse a)) -> + (ByteStringLazy -> IO ByteStringLazy) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) +receiveBody f _ = + stream $ \_ s h x -> + pure (f s h (ResponseBody x)) + +-- | Deserialise an entire response body, such as an XML or JSON payload. +deserialise :: + MonadResource m => + (ByteStringLazy -> Either String b) -> + (Int -> ResponseHeaders -> b -> Either String (AWSResponse a)) -> + (ByteStringLazy -> IO ByteStringLazy) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) +deserialise reader parser responseBodyHook Service {..} _ rs = + Except.runExceptT $ do + let status = Client.responseStatus rs + headers = Client.responseHeaders rs + + body <- sinkLBS (Client.responseBody rs) >>= liftIO . responseBodyHook + + unless (check status) $ Except.throwE (error status headers body) + + case reader body >>= parser (fromEnum status) headers of + Right ok -> pure (ok <$ rs) + Left err -> + Except.throwE $ + SerializeError (SerializeError' abbrev status (Just body) err) + +-- | Stream a raw response body, such as an S3 object payload. +stream :: + MonadResource m => + ( ClientResponse () -> + Int -> + ResponseHeaders -> + ClientBody -> + m (Either String (AWSResponse a)) + ) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) +stream parser Service {..} _ rs = + Except.runExceptT $ do + let status = Client.responseStatus rs + headers = Client.responseHeaders rs + body = Client.responseBody rs + + unless (check status) $ do + lazy <- sinkLBS body + Except.throwE (error status headers lazy) + + lift (parser (void rs) (fromEnum status) headers body) >>= \case + Right ok -> pure (ok <$ rs) + Left err -> + Except.throwE $ + SerializeError (SerializeError' abbrev status Nothing err) + +sinkLBS :: MonadResource m => ClientBody -> m ByteStringLazy +sinkLBS bdy = liftResourceT (bdy `Conduit.connect` Conduit.Binary.sinkLbs) diff --git a/src/Amazonka/Sign/V2.hs b/src/Amazonka/Sign/V2.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Sign/V2.hs @@ -0,0 +1,86 @@ +-- | +-- Module : Amazonka.Sign.V2 +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Sign.V2 + ( v2, + ) +where + +import qualified Amazonka.Bytes as Bytes +import qualified Amazonka.Crypto as Crypto +import Amazonka.Data +import Amazonka.Prelude hiding (error) +import Amazonka.Types hiding (presign, sign) +import qualified Data.ByteString.Char8 as BS8 +import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Types.URI as URI + +data V2 = V2 + { metaTime :: UTCTime, + metaEndpoint :: Endpoint, + metaSignature :: ByteString + } + +instance ToLog V2 where + build V2 {..} = + buildLines + [ "[Version 2 Metadata] {", + " time = " <> build metaTime, + " endpoint = " <> build (host metaEndpoint), + " signature = " <> build metaSignature, + "}" + ] + +v2 :: Signer +v2 = Signer sign (const sign) -- FIXME: revisit v2 presigning. + +sign :: Algorithm a +sign Request {service = Service {..}, ..} AuthEnv {..} r t = Signed meta rq + where + meta = Meta (V2 t end signature) + + rq = + (newClientRequest end timeout) + { Client.method = meth, + Client.path = path', + Client.queryString = toBS authorised, + Client.requestHeaders = headers', + Client.requestBody = toRequestBody body + } + + meth = toBS method + path' = toBS (escapePath $ basePath <> path) + + end@Endpoint {..} = endpoint r + + authorised = pair "Signature" (URI.urlEncode True signature) query + + signature = + Bytes.encodeBase64 + . Crypto.hmacSHA256 (toBS secretAccessKey) + $ BS8.intercalate + "\n" + [ meth, + host, + path', + toBS query' + ] + + query' = + pair "Version" version + . pair "SignatureVersion" ("2" :: ByteString) + . pair "SignatureMethod" ("HmacSHA256" :: ByteString) + . pair "Timestamp" time + . pair "AWSAccessKeyId" (toBS accessKeyId) + $ query <> maybe mempty toQuery token + + token = ("SecurityToken" :: ByteString,) . toBS <$> sessionToken + + headers' = hdr HTTP.hDate time headers + + time = toBS (Time t :: ISO8601) diff --git a/src/Amazonka/Sign/V2Header.hs b/src/Amazonka/Sign/V2Header.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Sign/V2Header.hs @@ -0,0 +1,219 @@ +-- | +-- Module : Amazonka.Sign.V2Header +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- This module provides an AWS compliant V2 Header request signer. It is based +-- heavily on , specifically boto's +-- @HmacAuthV1Handler@ AWS capable signer. AWS documentation is available +-- . +-- +-- Notice: Limitations include an inability to sign with a security token and +-- inability to overwrite the @Date@ header with an expiry. +module Amazonka.Sign.V2Header + ( v2Header, + newSigner, + toSignerQueryBS, + constructSigningHeader, + constructSigningQuery, + constructFullPath, + unionNecessaryHeaders, + ) +where + +import qualified Amazonka.Bytes as Bytes +import qualified Amazonka.Crypto as Crypto +import Amazonka.Data +import qualified Amazonka.Data.Query as Query +import Amazonka.Prelude +import Amazonka.Types hiding (presign, sign) +import qualified Data.ByteString.Builder as Build +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI +import qualified Data.Function as Function +import qualified Data.List as List +import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Types.URI as URI + +data V2Header = V2Header + { metaTime :: UTCTime, + metaEndpoint :: Endpoint, + metaSignature :: ByteString, + headers :: HTTP.RequestHeaders, + signer :: ByteString + } + +instance ToLog V2Header where + build V2Header {..} = + buildLines + [ "[Version 2 Header Metadata] {", + " time = " <> build metaTime, + " endpoint = " <> build (host metaEndpoint), + " signature = " <> build metaSignature, + " headers = " <> build headers, + " signer = " <> build signer, + "}" + ] + +v2Header :: Signer +v2Header = Signer sign (const sign) + +sign :: Algorithm a +sign Request {..} AuthEnv {..} r t = Signed meta rq + where + meta = Meta (V2Header t end signature headers signer) + + signer = newSigner headers' meth path' query + + rq = + (newClientRequest end timeout) + { Client.method = meth, + Client.path = path', + Client.queryString = toBS query, + Client.requestHeaders = headers', + Client.requestBody = toRequestBody body + } + + meth = toBS method + path' = toBS (escapePath $ basePath <> path) + + end@Endpoint {basePath} = endpoint r + + Service {timeout, endpoint} = service + + signature = + Bytes.encodeBase64 + . Crypto.hmacSHA1 (toBS secretAccessKey) + $ signer + + headers' = + headers + & hdr HTTP.hAuthorization ("AWS " <> toBS accessKeyId <> ":" <> signature) + & hdr HTTP.hDate time + + time = toBS (Time t :: RFC822) + +-- | Construct a full header signer following the V2 Header scheme +newSigner :: + HTTP.RequestHeaders -> + ByteString -> + ByteString -> + Query.QueryString -> + ByteString +newSigner headers method path query = signer + where + signer = + BS8.intercalate + "\n" + ( method + : map constructSigningHeader (List.sort filteredHeaders) + ++ [constructFullPath path (toSignerQueryBS filteredQuery)] + ) + + filteredHeaders = unionNecessaryHeaders (filter isInterestingHeader headers) + + filteredQuery = constructSigningQuery query + +-- | The following function mostly follows the toBS in amazonka QueryString +-- except for single QValue or single QPair keys not being suffixed with +-- an equals. +toSignerQueryBS :: Query.QueryString -> ByteString +toSignerQueryBS = + LBS.toStrict . Build.toLazyByteString . cat . List.sort . enc Nothing + where + enc :: Maybe ByteString -> Query.QueryString -> [ByteString] + enc p = \case + Query.QList xs -> concatMap (enc p) xs + Query.QPair (URI.urlEncode True -> k) x + | Just n <- p -> enc (Just (n <> kdelim <> k)) x -- .key + | otherwise -> enc (Just k) x -- key + Query.QValue (Just (URI.urlEncode True -> v)) + | Just n <- p -> [n <> vsep <> v] -- key=value + | otherwise -> [v] + _ + | Just n <- p -> [n] + | otherwise -> [] + + cat :: [ByteString] -> ByteStringBuilder + cat [] = mempty + cat [x] = Build.byteString x + cat (x : xs) = Build.byteString x <> ksep <> cat xs + + kdelim = "." + ksep = "&" + vsep = "=" + +hasAWSPrefix :: CI.CI ByteString -> Bool +hasAWSPrefix = BS8.isPrefixOf "aws-" . CI.foldedCase + +-- | Filter for 'interesting' keys within a QueryString +isInterestingQueryKey :: ByteString -> Bool +isInterestingQueryKey = \case + "acl" -> True + "cors" -> True + "defaultObjectAcl" -> True + "location" -> True + "logging" -> True + "partNumber" -> True + "policy" -> True + "requestPayment" -> True + "torrent" -> True + "versioning" -> True + "versionId" -> True + "versions" -> True + "website" -> True + "uploads" -> True + "uploadId" -> True + "response-content-type" -> True + "response-content-language" -> True + "response-expires" -> True + "response-cache-control" -> True + "response-content-disposition" -> True + "response-content-encoding" -> True + "delete" -> True + "lifecycle" -> True + "tagging" -> True + "restore" -> True + "storageClass" -> True + "websiteConfig" -> True + "compose" -> True + _ -> False + +-- | Filter for 'interesting' header fields +isInterestingHeader :: HTTP.Header -> Bool +isInterestingHeader (name, _) + | name == HTTP.hDate = True + | name == HTTP.hContentMD5 = True + | name == HTTP.hContentType = True + | hasAWSPrefix name = True + | otherwise = False + +-- | Constructs a query string for signing +constructSigningQuery :: Query.QueryString -> Query.QueryString +constructSigningQuery = \case + Query.QValue {} -> Query.QValue Nothing + Query.QList qs -> Query.QList (map constructSigningQuery qs) + Query.QPair k v + | isInterestingQueryKey k -> Query.QPair k v + | otherwise -> Query.QValue Nothing + +-- | Construct a header string for signing +constructSigningHeader :: HTTP.Header -> ByteString +constructSigningHeader (name, value) + | hasAWSPrefix name = CI.foldedCase name <> ":" <> value + | otherwise = value + +constructFullPath :: ByteString -> ByteString -> ByteString +constructFullPath path q + | BS8.null q = path + | otherwise = path <> "?" <> q + +unionNecessaryHeaders :: [HTTP.Header] -> [HTTP.Header] +unionNecessaryHeaders = + flip + (List.unionBy (Function.on (==) fst)) + [ (HTTP.hContentMD5, ""), + (HTTP.hContentType, "") + ] diff --git a/src/Amazonka/Sign/V4.hs b/src/Amazonka/Sign/V4.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Sign/V4.hs @@ -0,0 +1,84 @@ +-- | +-- Module : Amazonka.Sign.V4 +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Sign.V4 + ( Base.V4 (..), + v4, + ) +where + +import Amazonka.Bytes +import Amazonka.Core.Lens.Internal ((<>~)) +import Amazonka.Data.Body +import Amazonka.Data.ByteString +import Amazonka.Data.Headers +import Amazonka.Data.Query +import Amazonka.Data.Time +import Amazonka.Prelude +import Amazonka.Request +import qualified Amazonka.Sign.V4.Base as Base +import qualified Amazonka.Sign.V4.Chunked as Chunked +import Amazonka.Types hiding (presign, sign) +import qualified Data.ByteString as BS +import qualified Data.CaseInsensitive as CI + +v4 :: Signer +v4 = Signer sign presign + +-- | +-- Presigns a URL according to the AWS Request Signature V4 spec . +-- In the case that the URL contains a payload that is not signed when sending requests to Amazon S3, a literal `UNSIGNED-PAYLOAD` +-- must be included when constructing the cannonical request. See +-- In the edge case that the request body is a @Amazonka.Data.Body.ChunkedBody@ we will also use the `UNSIGNED-PAYLOAD` literal as we won't consume the stream +-- to hash it. +presign :: Seconds -> Algorithm a +presign ex rq@Request {body, service} a region ts = + Base.signRequest meta mempty auth + where + auth = clientRequestQuery <>~ ("&X-Amz-Signature=" <> toBS (Base.metaSignature meta)) + + meta = Base.signMetadata a region ts presigner digest (prepare rq) + + presigner c shs = + pair (CI.original hAMZAlgorithm) Base.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 <$> sessionToken a) + + digest = + case body of + Chunked _ -> unsignedPayload + Hashed (HashedStream h _ _) -> Base.Tag $ encodeBase16 h + Hashed (HashedBytes h b) + | BS.null b && signingName service == "s3" -> unsignedPayload + | otherwise -> Base.Tag $ encodeBase16 h + + unsignedPayload = Base.Tag "UNSIGNED-PAYLOAD" + + prepare :: Request a -> Request a + prepare r@Request {headers} = r {headers = hdr hHost realHost headers} + + realHost = + case (secure, port) of + (False, 80) -> host + (True, 443) -> host + _ -> mconcat [host, ":", toBS port] + + Endpoint {host, port, secure} = endpoint service region + +sign :: Algorithm a +sign rq@Request {body} a r ts = + case body of + Chunked x -> Chunked.chunked x rq a r ts + Hashed x -> hashed x rq a r ts + +hashed :: HashedBody -> Algorithm a +hashed x rq a r ts = + let (meta, auth) = Base.base (Base.Tag (sha256Base16 x)) rq a r ts + in Base.signRequest meta (toRequestBody (Hashed x)) auth diff --git a/src/Amazonka/Sign/V4/Base.hs b/src/Amazonka/Sign/V4/Base.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Sign/V4/Base.hs @@ -0,0 +1,311 @@ +-- | +-- Module : Amazonka.Sign.V4.Base +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Sign.V4.Base where + +import qualified Amazonka.Bytes as Bytes +import Amazonka.Core.Lens.Internal ((<>~), (^.)) +import qualified Amazonka.Crypto as Crypto +import Amazonka.Data hiding (Path) +import Amazonka.Prelude +import Amazonka.Request +import Amazonka.Types +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +import qualified Data.CaseInsensitive as CI +import qualified Data.Foldable as Foldable +import qualified Data.Map.Strict as Map +import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Types as HTTP + +data V4 = V4 + { metaTime :: UTCTime, + metaMethod :: Method, + metaPath :: Path, + metaEndpoint :: Endpoint, + metaCredential :: Credential, + metaCanonicalQuery :: CanonicalQuery, + metaCanonicalRequest :: CanonicalRequest, + metaCanonicalHeaders :: CanonicalHeaders, + metaSignedHeaders :: SignedHeaders, + metaStringToSign :: StringToSign, + metaSignature :: Signature, + metaHeaders :: [Header], + metaTimeout :: Maybe Seconds + } + +instance ToLog V4 where + build V4 {metaEndpoint = Endpoint {host}, ..} = + buildLines + [ "[Version 4 Metadata] {", + " time = " <> build metaTime, + " endpoint = " <> build host, + " credential = " <> build metaCredential, + " signed headers = " <> build metaSignedHeaders, + " signature = " <> build metaSignature, + " string to sign = {", + build metaStringToSign, + " }", + " canonical request = {", + build metaCanonicalRequest, + " }", + "}" + ] + +base :: + Hash -> + Request a -> + AuthEnv -> + Region -> + UTCTime -> + (V4, ClientRequest -> ClientRequest) +base h rq a region ts = (meta, auth) + where + auth = clientRequestHeaders <>~ [(HTTP.hAuthorization, authorisation meta)] + + meta = signMetadata a region ts presigner h (prepare rq) + + presigner _ _ = id + + prepare :: Request a -> Request a + prepare r@Request {headers} = + r + { headers = + headers + & hdr hHost realHost + & hdr hAMZDate (toBS (Time ts :: AWSTime)) + & hdr hAMZContentSHA256 (toBS h) + & maybe id (hdr hAMZToken . toBS) (sessionToken a) + } + + realHost = + case (secure, port) of + (False, 80) -> host + (True, 443) -> host + _ -> mconcat [host, ":", toBS port] + + Endpoint {host, port, secure} = endpoint (service rq) region + +-- | 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 the dependency, syntactic length, +-- and the ToByteString instance. +newtype Tag (s :: Symbol) a = Tag {untag :: a} + deriving stock (Show) + +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 CanonicalPath = Tag "canonical-path" ByteString + +type Path = Tag "path" ByteString + +type Signature = Tag "signature" ByteString + +authorisation :: V4 -> ByteString +authorisation V4 {..} = + mconcat + [ algorithm, + " Credential=", + toBS metaCredential, + ", SignedHeaders=", + toBS metaSignedHeaders, + ", Signature=", + toBS metaSignature + ] + +signRequest :: + -- | Pre-signRequestd signing metadata. + V4 -> + -- | The request body. + Client.RequestBody -> + -- | Insert authentication information. + (ClientRequest -> ClientRequest) -> + Signed a +signRequest m@V4 {..} b auth = Signed (Meta m) (auth rq) + where + rq = + (newClientRequest metaEndpoint metaTimeout) + { Client.method = toBS metaMethod, + Client.path = toBS metaPath, + Client.queryString = qry, + Client.requestHeaders = metaHeaders, + Client.requestBody = b + } + + qry + | BS.null x = x + | otherwise = '?' `BS8.cons` x + where + x = toBS metaCanonicalQuery + +signMetadata :: + AuthEnv -> + Region -> + UTCTime -> + (Credential -> SignedHeaders -> QueryString -> QueryString) -> + Hash -> + Request a -> + V4 +signMetadata a r ts presign digest rq@Request {headers, method, query, service} = + V4 + { metaTime = ts, + metaMethod = method', + metaPath = path, + metaEndpoint = end, + metaCredential = cred, + metaCanonicalQuery = query', + metaCanonicalRequest = crq, + metaCanonicalHeaders = chs, + metaSignedHeaders = shs, + metaStringToSign = sts, + metaSignature = signature (secretAccessKey a ^. _Sensitive) scope sts, + metaHeaders = headers, + metaTimeout = timeout service + } + where + query' = canonicalQuery $ presign cred shs query + + sts = stringToSign ts scope crq + cred = credential (accessKeyId a) scope + scope = credentialScope service end ts + crq = canonicalRequest method' cpath digest query' chs shs + + chs = canonicalHeaders normalisedHeaders + shs = signedHeaders normalisedHeaders + normalisedHeaders = normaliseHeaders headers + + end = endpoint service r + method' = Tag $ toBS method + path = escapedPath r rq + cpath = canonicalPath r rq + +algorithm :: ByteString +algorithm = "AWS4-HMAC-SHA256" + +signature :: SecretKey -> CredentialScope -> StringToSign -> Signature +signature k c = Tag . Bytes.encodeBase16 . Crypto.hmacSHA256 signingKey . untag + where + signingKey = Foldable.foldl' hmac ("AWS4" <> toBS k) (untag c) + + hmac x y = Bytes.convert (Crypto.hmacSHA256 x y) + +stringToSign :: UTCTime -> CredentialScope -> CanonicalRequest -> StringToSign +stringToSign t c r = + Tag $ + BS8.intercalate + "\n" + [ algorithm, + toBS (Time t :: AWSTime), + toBS c, + Bytes.encodeBase16 . Crypto.hashSHA256 $ toBS r + ] + +credential :: AccessKey -> CredentialScope -> Credential +credential k c = Tag (toBS k <> "/" <> toBS c) + +credentialScope :: Service -> Endpoint -> UTCTime -> CredentialScope +credentialScope Service {signingName} Endpoint {scope} t = + Tag + [ toBS (Time t :: BasicTime), + toBS scope, + toBS signingName, + "aws4_request" + ] + +canonicalRequest :: + Method -> + CanonicalPath -> + 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 :: Region -> Request a -> Path +escapedPath r rq@Request {service = Service {abbrev}} = + Tag $ case abbrev of + "S3" -> toBS $ escapePath p + _ -> toBS $ escapePath $ collapsePath p + where + p = fullRawPath r rq + +canonicalPath :: Region -> Request a -> CanonicalPath +canonicalPath r rq@Request {service = Service {abbrev}} = + Tag $ case abbrev of + "S3" -> toBS $ escapePath p + _ -> toBS $ escapePathTwice $ collapsePath p + where + p = fullRawPath r rq + +-- | The complete raw path for a request, including any 'basePath' on +-- the endpoint. +fullRawPath :: Region -> Request a -> RawPath +fullRawPath r Request {path, service = Service {endpoint}} = + basePath (endpoint r) <> path + +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 . BSL.toStrict . BSB.toLazyByteString . Foldable.foldMap (uncurry f) . untag + where + f k v = BSB.byteString k <> BSB.char7 ':' <> BSB.byteString (stripBS v) <> BSB.char7 '\n' + +signedHeaders :: NormalisedHeaders -> SignedHeaders +signedHeaders = Tag . BS8.intercalate ";" . map fst . untag + +normaliseHeaders :: [Header] -> NormalisedHeaders +normaliseHeaders = + Tag + . map (first CI.foldedCase) + . Map.toAscList + . Map.delete "authorization" + . Map.delete "content-length" + . Map.fromListWith const diff --git a/src/Amazonka/Sign/V4/Chunked.hs b/src/Amazonka/Sign/V4/Chunked.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Sign/V4/Chunked.hs @@ -0,0 +1,136 @@ +-- | +-- Module : Amazonka.Sign.V4.Chunked +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Sign.V4.Chunked where + +import qualified Amazonka.Bytes as Bytes +import Amazonka.Core.Lens.Internal ((^.)) +import qualified Amazonka.Crypto as Crypto +import Amazonka.Data +import Amazonka.Prelude as Prelude +import Amazonka.Sign.V4.Base as V4 hiding (algorithm) +import Amazonka.Types +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Build +import qualified Data.ByteString.Char8 as BS8 +import Data.Conduit (ConduitM) +import qualified Data.Conduit as Conduit +import qualified Network.HTTP.Types as HTTP +import qualified Numeric + +chunked :: ChunkedBody -> Algorithm a +chunked + c@ChunkedBody {length = len} + rq@Request {service = service@Service {endpoint}} + a + region + ts = + signRequest meta (toRequestBody body) auth + where + (meta, auth) = V4.base (Tag digest) (prepare rq) a region ts + + -- Although https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-streaming.html says to include + -- `Content-Encoding: aws-chunked`, we don't. If it's the only header, S3 will remove + -- `aws-chunked` leaving a blank header, and store `"ContentEncoding": ""` in the object's metadata. + -- This breaks some CDNs and HTTP clients. + -- + -- According to https://github.com/fog/fog-aws/pull/147 , AWS support have confirmed that the + -- header is not strictly necessary, and S3 will figure out that it's a chunked body. + prepare :: Request a -> Request a + prepare r@Request {headers} = + r + { headers = + headers + <> [ (hAMZDecodedContentLength, toBS len), + (HTTP.hContentLength, toBS (metadataLength c)) + ] + } + + body = Chunked (c `fuseChunks` sign (metaSignature meta)) + + sign :: Monad m => Signature -> ConduitM ByteString ByteString m () + sign prev = do + mx <- Conduit.await + + let next = chunkSignature prev (fromMaybe mempty mx) + + case mx of + Nothing -> Conduit.yield (chunkData next mempty) + Just x -> Conduit.yield (chunkData next x) >> sign next + + chunkData next x = + toBS $ + Build.word64Hex (fromIntegral (BS.length x)) + <> Build.byteString chunkSignatureHeader + <> Build.byteString (toBS next) + <> Build.byteString crlf + <> Build.byteString x + <> Build.byteString crlf + + chunkSignature prev x = + signature (secretAccessKey a ^. _Sensitive) scope (chunkStringToSign prev x) + + chunkStringToSign prev x = + Tag $ + BS8.intercalate + "\n" + [ algorithm, + time, + toBS scope, + toBS prev, + sha256Empty, + sha256 x + ] + + time :: ByteString + time = toBS (Time ts :: AWSTime) + + scope :: CredentialScope + scope = credentialScope service end ts + + end :: Endpoint + end = endpoint region + +metadataLength :: ChunkedBody -> Integer +metadataLength c = + -- Number of full sized chunks. + fullChunks c * chunkLength (size c) + -- Non-full chunk preceeding the final chunk. + + maybe 0 chunkLength (remainderBytes c) + -- The final empty chunk. + + chunkLength (0 :: Integer) + where + chunkLength :: Integral a => a -> Integer + chunkLength (toInteger -> n) = + fromIntegral (Prelude.length (Numeric.showHex n "")) + + headerLength + + signatureLength + + crlfLength + + n + + crlfLength + + headerLength = toInteger (BS.length chunkSignatureHeader) + crlfLength = toInteger (BS.length crlf) + signatureLength = 64 + +sha256 :: ByteString -> ByteString +sha256 = Bytes.encodeBase16 . Crypto.hashSHA256 + +sha256Empty :: ByteString +sha256Empty = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" + +algorithm :: ByteString +algorithm = "AWS4-HMAC-SHA256-PAYLOAD" + +digest :: ByteString +digest = "STREAMING-AWS4-HMAC-SHA256-PAYLOAD" + +chunkSignatureHeader :: ByteString +chunkSignatureHeader = ";chunk-signature=" + +crlf :: ByteString +crlf = "\r\n" diff --git a/src/Amazonka/Types.hs b/src/Amazonka/Types.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Types.hs @@ -0,0 +1,1043 @@ +-- | +-- Module : Amazonka.Types +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Types + ( -- * Authentication + + -- ** Credentials + AccessKey (..), + SecretKey (..), + SessionToken (..), + + -- *** Optics + _AccessKey, + _SecretKey, + _SessionToken, + + -- ** Environment + Auth (..), + withAuth, + AuthEnv (..), + + -- *** Lenses + authEnv_accessKeyId, + authEnv_secretAccessKey, + authEnv_sessionToken, + authEnv_expiration, + + -- * Signing + Algorithm, + Meta (..), + Signer (..), + Signed (..), + + -- ** Lenses + signed_signedMeta, + signed_signedRequest, + + -- * Service + Abbrev, + Service (..), + S3AddressingStyle (..), + + -- ** Optics + _Abbrev, + service_abbrev, + service_signer, + service_signingName, + service_version, + service_s3AddressingStyle, + service_endpointPrefix, + service_endpoint, + service_timeout, + service_check, + service_error, + service_retry, + + -- * Requests + AWSRequest (..), + Request (..), + requestSign, + requestPresign, + requestUnsigned, + + -- ** Lenses + request_service, + request_method, + request_path, + request_query, + request_headers, + request_body, + + -- * Retries + Retry (..), + + -- ** Lenses + retry_base, + retry_growth, + retry_attempts, + retry_check, + + -- * Errors + AsError (..), + Error (..), + + -- ** HTTP Errors + Client.HttpException, + + -- ** Serialize Errors + SerializeError (..), + + -- *** Lenses + serializeError_abbrev, + serializeError_status, + serializeError_body, + serializeError_message, + + -- ** Service Errors + ServiceError (..), + + -- *** Lenses + serviceError_abbrev, + serviceError_status, + serviceError_headers, + serviceError_code, + serviceError_message, + serviceError_requestId, + + -- ** Error Types + ErrorCode (..), + newErrorCode, + ErrorMessage (..), + RequestId (..), + + -- *** Optics + _ErrorCode, + _ErrorMessage, + _RequestId, + + -- * Regions + Region + ( Ohio, + NorthVirginia, + NorthCalifornia, + Oregon, + CapeTown, + HongKong, + Hyderabad, + Jakarta, + Melbourne, + Mumbai, + Osaka, + Seoul, + Singapore, + Sydney, + Tokyo, + Montreal, + Frankfurt, + Ireland, + London, + Milan, + Paris, + Spain, + Stockholm, + Zurich, + Bahrain, + UAE, + SaoPaulo, + GovCloudEast, + GovCloudWest, + Beijing, + Ningxia, + .. + ), + + -- * Endpoints + Endpoint (..), + + -- ** Lenses + endpoint_host, + endpoint_basePath, + endpoint_secure, + endpoint_port, + endpoint_scope, + + -- * HTTP + ClientRequest, + ClientResponse, + ClientBody, + newClientRequest, + + -- ** Seconds + Seconds (..), + toSeconds, + toMicroseconds, + ) +where + +import qualified Amazonka.Core.Lens.Internal as Lens +import Amazonka.Data +import Amazonka.Prelude hiding (error) +import Control.Concurrent (ThreadId) +import Control.Monad.Trans.Resource (ResourceT) +import Data.Conduit (ConduitM) +import Data.IORef (IORef, readIORef) +import qualified Data.Text as Text +import Data.Time (defaultTimeLocale, formatTime, parseTimeM) +import qualified Network.HTTP.Client as Client +import Network.HTTP.Types.Method (StdMethod) +import Network.HTTP.Types.Status (Status) + +-- | A convenience alias to avoid type ambiguity. +type ClientRequest = Client.Request + +-- | Construct a 'ClientRequest' using common parameters such as TLS and prevent +-- throwing errors when receiving erroneous status codes in respones. +newClientRequest :: Endpoint -> Maybe Seconds -> ClientRequest +newClientRequest Endpoint {host, secure, port} timeout = + Client.defaultRequest + { Client.secure = secure, + Client.host = host, + Client.port = port, + Client.redirectCount = 0, + Client.responseTimeout = + case timeout of + Nothing -> Client.responseTimeoutNone + Just n -> Client.responseTimeoutMicro (toMicroseconds n) + } + +-- | A convenience alias encapsulating the common 'Response'. +type ClientResponse = Client.Response + +-- | A convenience alias encapsulating the common 'Response' body. +type ClientBody = ConduitM () ByteString (ResourceT IO) () + +-- | Abbreviated service name. +newtype Abbrev = Abbrev {fromAbbrev :: Text} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (IsString, FromXML, FromJSON, FromText, ToText, ToLog) + +{-# INLINE _Abbrev #-} +_Abbrev :: Iso' Abbrev Text +_Abbrev = Lens.coerced + +newtype ErrorCode = ErrorCode Text + deriving stock (Eq, Ord, Show) + deriving newtype (ToText, ToLog) + +{-# INLINE _ErrorCode #-} +_ErrorCode :: Iso' ErrorCode Text +_ErrorCode = Lens.coerced + +instance IsString ErrorCode where + fromString = newErrorCode . fromString + +instance FromJSON ErrorCode where + parseJSON = parseJSONText "ErrorCode" + +instance FromXML ErrorCode where + parseXML = parseXMLText "ErrorCode" + +instance FromText ErrorCode where + fromText = pure . newErrorCode + +-- | Construct an 'ErrorCode'. +newErrorCode :: Text -> ErrorCode +newErrorCode = ErrorCode . strip . unnamespace + where + -- Common suffixes are stripped since the service definitions are ambigiuous + -- as to whether the error shape's name, or the error code is present + -- in the response. + strip x = + fromMaybe x $ + Text.stripSuffix "Exception" x <|> Text.stripSuffix "Fault" x + + -- Removing the (potential) leading ...# namespace. + unnamespace x = + case Text.break (== '#') x of + (ns, e) + | Text.null e -> ns + | otherwise -> Text.drop 1 e + +newtype ErrorMessage = ErrorMessage {fromErrorMessage :: Text} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (IsString, FromXML, FromJSON, FromText, ToText, ToLog) + +{-# INLINE _ErrorMessage #-} +_ErrorMessage :: Iso' ErrorMessage Text +_ErrorMessage = Lens.coerced + +newtype RequestId = RequestId {fromRequestId :: Text} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (IsString, FromXML, FromJSON, FromText, ToText, ToLog) + +{-# INLINE _RequestId #-} +_RequestId :: Iso' RequestId Text +_RequestId = Lens.coerced + +-- | An error type representing errors that can be attributed to this library. +data Error + = TransportError Client.HttpException + | SerializeError SerializeError + | ServiceError ServiceError + deriving stock (Show, Generic) + +instance Exception Error + +instance ToLog Error where + build = \case + TransportError e -> build e + SerializeError e -> build e + ServiceError e -> build e + +data SerializeError = SerializeError' + { abbrev :: Abbrev, + status :: Status, + -- | The response body, if the response was not streaming. + body :: Maybe ByteStringLazy, + message :: String + } + deriving stock (Eq, Show, Generic) + +instance ToLog SerializeError where + build SerializeError' {..} = + buildLines + [ "[SerializeError] {", + " service = " <> build abbrev, + " status = " <> build status, + " message = " <> build message, + " body = " <> build body, + "}" + ] + +{-# INLINE serializeError_abbrev #-} +serializeError_abbrev :: Lens' SerializeError Abbrev +serializeError_abbrev f e@SerializeError' {abbrev} = f abbrev <&> \abbrev' -> (e :: SerializeError) {abbrev = abbrev'} + +{-# INLINE serializeError_status #-} +serializeError_status :: Lens' SerializeError Status +serializeError_status f e@SerializeError' {status} = f status <&> \status' -> (e :: SerializeError) {status = status'} + +{-# INLINE serializeError_body #-} +serializeError_body :: Lens' SerializeError (Maybe ByteStringLazy) +serializeError_body f e@SerializeError' {body} = f body <&> \body' -> (e :: SerializeError) {body = body'} + +{-# INLINE serializeError_message #-} +serializeError_message :: Lens' SerializeError String +serializeError_message f e@SerializeError' {message} = f message <&> \message' -> (e :: SerializeError) {message = message'} + +data ServiceError = ServiceError' + { abbrev :: Abbrev, + status :: Status, + headers :: [Header], + code :: ErrorCode, + message :: Maybe ErrorMessage, + requestId :: Maybe RequestId + } + deriving stock (Eq, Show, Generic) + +instance ToLog ServiceError where + build ServiceError' {..} = + buildLines + [ "[ServiceError] {", + " service = " <> build abbrev, + " status = " <> build status, + " code = " <> build code, + " message = " <> build message, + " request-id = " <> build requestId, + "}" + ] + +{-# INLINE serviceError_abbrev #-} +serviceError_abbrev :: Lens' ServiceError Abbrev +serviceError_abbrev f e@ServiceError' {abbrev} = f abbrev <&> \abbrev' -> (e :: ServiceError) {abbrev = abbrev'} + +{-# INLINE serviceError_status #-} +serviceError_status :: Lens' ServiceError Status +serviceError_status f e@ServiceError' {status} = f status <&> \status' -> (e :: ServiceError) {status = status'} + +{-# INLINE serviceError_headers #-} +serviceError_headers :: Lens' ServiceError [Header] +serviceError_headers f e@ServiceError' {headers} = f headers <&> \headers' -> (e :: ServiceError) {headers = headers'} + +{-# INLINE serviceError_code #-} +serviceError_code :: Lens' ServiceError ErrorCode +serviceError_code f e@ServiceError' {code} = f code <&> \code' -> e {code = code'} + +{-# INLINE serviceError_message #-} +serviceError_message :: Lens' ServiceError (Maybe ErrorMessage) +serviceError_message f e@ServiceError' {message} = f message <&> \message' -> (e :: ServiceError) {message = message'} + +{-# INLINE serviceError_requestId #-} +serviceError_requestId :: Lens' ServiceError (Maybe RequestId) +serviceError_requestId f e@ServiceError' {requestId} = f requestId <&> \requestId' -> (e :: ServiceError) {requestId = requestId'} + +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 Client.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 = Lens.exception + +instance AsError Error where + _Error = id + + _TransportError = Lens.prism TransportError $ \case + TransportError e -> Right e + x -> Left x + + _SerializeError = Lens.prism SerializeError $ \case + SerializeError e -> Right e + x -> Left x + + _ServiceError = Lens.prism ServiceError $ \case + ServiceError e -> Right e + x -> Left x + +data Endpoint = Endpoint + { -- | The host to make requests to. Usually something like + -- @s3.us-east-1.amazonaws.com@. + host :: ByteString, + -- | Path segment prepended to the request path of any request + -- made to this endpoint. This is useful if you want to use the + -- AWS API Gateway Management API, which requires you to override + -- the client endpoint including a leading path segment (either + -- the stage or, on a custom domain, the mapped base path). + basePath :: RawPath, + secure :: Bool, + port :: Int, + -- | Signing scope, usually a region like @us-east-1@. + scope :: ByteString + } + deriving stock (Eq, Show, Generic) + +{-# INLINE endpoint_host #-} +endpoint_host :: Lens' Endpoint ByteString +endpoint_host f e@Endpoint {host} = f host <&> \host' -> e {host = host'} + +{-# INLINE endpoint_basePath #-} +endpoint_basePath :: Lens' Endpoint RawPath +endpoint_basePath f e@Endpoint {basePath} = f basePath <&> \basePath' -> e {basePath = basePath'} + +{-# INLINE endpoint_secure #-} +endpoint_secure :: Lens' Endpoint Bool +endpoint_secure f e@Endpoint {secure} = f secure <&> \secure' -> e {secure = secure'} + +{-# INLINE endpoint_port #-} +endpoint_port :: Lens' Endpoint Int +endpoint_port f e@Endpoint {port} = f port <&> \port' -> e {port = port'} + +{-# INLINE endpoint_scope #-} +endpoint_scope :: Lens' Endpoint ByteString +endpoint_scope f e@Endpoint {scope} = f scope <&> \scope' -> e {scope = scope'} + +-- | Constants and predicates used to create a 'RetryPolicy'. +data Retry = Exponential + { base :: Double, + growth :: Int, + attempts :: Int, + -- | Returns a descriptive name for logging + -- if the request should be retried. + check :: ServiceError -> Maybe Text + } + deriving stock (Generic) + +{-# INLINE retry_base #-} +retry_base :: Lens' Retry Double +retry_base f r@Exponential {base} = f base <&> \base' -> r {base = base'} + +{-# INLINE retry_growth #-} +retry_growth :: Lens' Retry Int +retry_growth f r@Exponential {growth} = f growth <&> \growth' -> r {growth = growth'} + +{-# INLINE retry_attempts #-} +retry_attempts :: Lens' Retry Int +retry_attempts f r@Exponential {attempts} = f attempts <&> \attempts' -> r {attempts = attempts'} + +{-# INLINE retry_check #-} +retry_check :: Lens' Retry (ServiceError -> Maybe Text) +retry_check f r@Exponential {check} = f check <&> \check' -> (r :: Retry) {check = check'} + +-- | Signing algorithm specific metadata. +data Meta where + Meta :: ToLog a => a -> Meta + +instance ToLog Meta where + build (Meta m) = build m + +-- | A signed 'ClientRequest' and associated metadata specific +-- to the signing algorithm, tagged with the initial request type +-- to be able to obtain the associated response, @'AWSResponse' a@. +data Signed a = Signed + { signedMeta :: Meta, + signedRequest :: ClientRequest + } + +{-# INLINE signed_signedMeta #-} +signed_signedMeta :: Lens' (Signed a) Meta +signed_signedMeta f s@Signed {signedMeta} = f signedMeta <&> \signedMeta' -> s {signedMeta = signedMeta'} + +{-# INLINE signed_signedRequest #-} +signed_signedRequest :: Lens' (Signed a) ClientRequest +signed_signedRequest f s@Signed {signedRequest} = f signedRequest <&> \signedRequest' -> s {signedRequest = signedRequest'} + +type Algorithm a = Request a -> AuthEnv -> Region -> UTCTime -> Signed a + +data Signer = Signer + { sign :: forall a. Algorithm a, + presign :: forall a. Seconds -> Algorithm a + } + +-- | Attributes and functions specific to an AWS service. +data Service = Service + { abbrev :: Abbrev, + signer :: Signer, + signingName :: ByteString, + version :: ByteString, + -- | Only service bindings using the s3vhost request plugin + -- (configured in the generator) will care about this field. It is + -- ignored otherwise. + s3AddressingStyle :: S3AddressingStyle, + endpointPrefix :: ByteString, + endpoint :: Region -> Endpoint, + timeout :: Maybe Seconds, + check :: Status -> Bool, + error :: Status -> [Header] -> ByteStringLazy -> Error, + retry :: Retry + } + deriving stock (Generic) + +{-# INLINE service_abbrev #-} +service_abbrev :: Lens' Service Abbrev +service_abbrev f s@Service {abbrev} = f abbrev <&> \abbrev' -> (s :: Service) {abbrev = abbrev'} + +{-# INLINE service_signer #-} +service_signer :: Lens' Service Signer +service_signer f s@Service {signer} = f signer <&> \signer' -> (s :: Service) {signer = signer'} + +{-# INLINE service_signingName #-} +service_signingName :: Lens' Service ByteString +service_signingName f s@Service {signingName} = f signingName <&> \signingName' -> s {signingName = signingName'} + +{-# INLINE service_version #-} +service_version :: Lens' Service ByteString +service_version f s@Service {version} = f version <&> \version' -> s {version = version'} + +{-# INLINE service_s3AddressingStyle #-} +service_s3AddressingStyle :: Lens' Service S3AddressingStyle +service_s3AddressingStyle f s@Service {s3AddressingStyle} = f s3AddressingStyle <&> \s3AddressingStyle' -> s {s3AddressingStyle = s3AddressingStyle'} + +{-# INLINE service_endpointPrefix #-} +service_endpointPrefix :: Lens' Service ByteString +service_endpointPrefix f s@Service {endpointPrefix} = f endpointPrefix <&> \endpointPrefix' -> s {endpointPrefix = endpointPrefix'} + +{-# INLINE service_endpoint #-} +service_endpoint :: Lens' Service (Region -> Endpoint) +service_endpoint f s@Service {endpoint} = f endpoint <&> \endpoint' -> s {endpoint = endpoint'} + +{-# INLINE service_timeout #-} +service_timeout :: Lens' Service (Maybe Seconds) +service_timeout f s@Service {timeout} = f timeout <&> \timeout' -> s {timeout = timeout'} + +{-# INLINE service_check #-} +service_check :: Lens' Service (Status -> Bool) +service_check f s@Service {check} = f check <&> \check' -> (s :: Service) {check = check'} + +{-# INLINE service_error #-} +service_error :: Lens' Service (Status -> [Header] -> ByteStringLazy -> Error) +service_error f s@Service {error} = f error <&> \error' -> (s :: Service) {error = error'} + +{-# INLINE service_retry #-} +service_retry :: Lens' Service Retry +service_retry f s@Service {retry} = f retry <&> \retry' -> (s :: Service) {retry = retry'} + +-- | When to rewrite S3 requests into /virtual-hosted style/. +-- +-- Requests to S3 can be rewritten to access buckets by setting the +-- @Host:@ header, which allows you to point a @CNAME@ record at an +-- Amazon S3 Bucket. +-- +-- Non-S3 object stores usually do not support this, which is usually +-- the only time you'll need to change this. +-- +-- /See:/ [Virtual hosting of buckets](https://docs.aws.amazon.com/AmazonS3/latest/userguide/VirtualHosting.html) +-- in the Amazon S3 User Guide. +-- +-- /See:/ [Changing the Addressing Style](https://boto3.amazonaws.com/v1/documentation/api/1.9.42/guide/s3.html#changing-the-addressing-style) +-- for the corresponding option in Boto 3. +data S3AddressingStyle + = -- | Rewrite S3 request paths only if they can be expressed + -- as a DNS label. This is the default. + S3AddressingStyleAuto + | -- | Do not ever rewrite S3 request paths. + S3AddressingStylePath + | -- | Force virtual hosted style rewrites without checking the + -- bucket name. + S3AddressingStyleVirtual + deriving stock (Eq, Show, Generic) + +-- | An unsigned request. +data Request a = Request + { service :: Service, + method :: StdMethod, + path :: RawPath, + query :: QueryString, + headers :: [Header], + body :: RequestBody + } + deriving stock (Generic) + +{-# INLINE request_service #-} +request_service :: Lens' (Request a) Service +request_service f rq@Request {service} = f service <&> \service' -> rq {service = service'} + +{-# INLINE request_method #-} +request_method :: Lens' (Request a) StdMethod +request_method f rq@Request {method} = f method <&> \method' -> rq {method = method'} + +{-# INLINE request_path #-} +request_path :: Lens' (Request a) RawPath +request_path f rq@Request {path} = f path <&> \path' -> rq {path = path'} + +{-# INLINE request_query #-} +request_query :: Lens' (Request a) QueryString +request_query f rq@Request {query} = f query <&> \query' -> rq {query = query'} + +{-# INLINE request_headers #-} +request_headers :: forall a. Lens' (Request a) [Header] +request_headers f rq@Request {headers} = f headers <&> \headers' -> (rq :: Request a) {headers = headers'} + +{-# INLINE request_body #-} +request_body :: forall a. Lens' (Request a) RequestBody +request_body f rq@Request {body} = f body <&> \body' -> (rq :: Request a) {body = body'} + +requestSign :: Algorithm a +requestSign rq@Request {service = Service {signer = Signer {sign}}} = sign rq + +requestPresign :: Seconds -> Algorithm a +requestPresign ex rq@Request {service = Service {signer = Signer {presign}}} = + presign ex rq + +-- | Create an unsigned 'ClientRequest'. You will almost never need to do this. +requestUnsigned :: Request a -> Region -> ClientRequest +requestUnsigned Request {service = Service {..}, ..} r = + (newClientRequest end timeout) + { Client.method = toBS method, + Client.path = toBS (escapePath path), + Client.queryString = toBS query, + Client.requestHeaders = headers, + Client.requestBody = toRequestBody body + } + where + end = endpoint r + +-- | Specify how a request can be de/serialised. +class AWSRequest a where + -- | The successful, expected response associated with a request. + type AWSResponse a :: Type + + request :: + -- | Overrides applied to the default 'Service'. + (Service -> Service) -> + a -> + Request a + + response :: + MonadResource m => + -- | Raw response body hook. + (ByteStringLazy -> IO ByteStringLazy) -> + Service -> + Proxy a -> + ClientResponse ClientBody -> + m (Either Error (ClientResponse (AWSResponse a))) + +-- | An access key ID. +-- +-- For example: @AKIAIOSFODNN7EXAMPLE@ +-- +-- /See:/ . +newtype AccessKey = AccessKey ByteString + deriving stock (Eq, Show, Read, Generic) + deriving newtype + ( IsString, + ToText, + FromText, + ToLog, + ToByteString, + ToQuery, + FromXML, + ToXML, + Hashable, + NFData + ) + +instance ToJSON AccessKey where + toJSON = toJSONText + +instance FromJSON AccessKey where + parseJSON = parseJSONText "AccessKey" + +_AccessKey :: Iso' AccessKey ByteString +_AccessKey = Lens.coerced + +-- | Secret access key credential. +-- +-- For example: @wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKE@ +-- +-- /See:/ . +newtype SecretKey = SecretKey ByteString + deriving stock (Eq, Generic) + deriving newtype + ( IsString, + ToText, + FromText, + ToByteString, + FromXML, + ToXML, + Hashable, + NFData + ) + +instance ToJSON SecretKey where + toJSON = toJSONText + +instance FromJSON SecretKey where + parseJSON = parseJSONText "SecretKey" + +_SecretKey :: Iso' SecretKey ByteString +_SecretKey = Lens.coerced + +-- | A session token used by STS to temporarily authorise access to +-- an AWS resource. +-- +-- /See:/ . +newtype SessionToken = SessionToken ByteString + deriving stock (Eq, Generic) + deriving newtype + ( IsString, + ToText, + FromText, + ToByteString, + FromXML, + ToXML, + Hashable, + NFData + ) + +instance ToJSON SessionToken where + toJSON = toJSONText + +instance FromJSON SessionToken where + parseJSON = parseJSONText "SessionToken" + +_SessionToken :: Iso' SessionToken ByteString +_SessionToken = Lens.coerced + +-- | The AuthN/AuthZ credential environment. +data AuthEnv = AuthEnv + { accessKeyId :: AccessKey, + secretAccessKey :: Sensitive SecretKey, + sessionToken :: Maybe (Sensitive SessionToken), + expiration :: Maybe ISO8601 + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToLog AuthEnv where + build AuthEnv {..} = + buildLines + [ "[Amazonka Auth] {", + " access key id = " <> build accessKeyId, + " secret access key = " <> build secretAccessKey, + " session token = " <> build sessionToken, + " expiration = " <> build (fmap (Lens.view _Time) expiration), + "}" + ] + +instance FromJSON AuthEnv where + parseJSON = withObject "AuthEnv" $ \o -> + AuthEnv + <$> o .: "AccessKeyId" + <*> o .: "SecretAccessKey" + <*> o .:? "Token" + <*> o .:? "Expiration" + +instance FromXML AuthEnv where + parseXML x = + AuthEnv + <$> x .@ "AccessKeyId" + <*> x .@ "SecretAccessKey" + <*> x .@? "SessionToken" + <*> x .@? "Expiration" + +{-# INLINE authEnv_accessKeyId #-} +authEnv_accessKeyId :: Lens' AuthEnv AccessKey +authEnv_accessKeyId f a@AuthEnv {accessKeyId} = f accessKeyId <&> \accessKeyId' -> a {accessKeyId = accessKeyId'} + +{-# INLINE authEnv_secretAccessKey #-} +authEnv_secretAccessKey :: Lens' AuthEnv (Sensitive SecretKey) +authEnv_secretAccessKey f a@AuthEnv {secretAccessKey} = f secretAccessKey <&> \secretAccessKey' -> a {secretAccessKey = secretAccessKey'} + +{-# INLINE authEnv_sessionToken #-} +authEnv_sessionToken :: Lens' AuthEnv (Maybe (Sensitive SessionToken)) +authEnv_sessionToken f a@AuthEnv {sessionToken} = f sessionToken <&> \sessionToken' -> a {sessionToken = sessionToken'} + +{-# INLINE authEnv_expiration #-} +authEnv_expiration :: Lens' AuthEnv (Maybe ISO8601) +authEnv_expiration f a@AuthEnv {expiration} = f expiration <&> \expiration' -> a {expiration = expiration'} + +-- | 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 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 (Ref _ r) f = liftIO (readIORef r) >>= f +withAuth (Auth e) f = f e + +-- | The available AWS regions. +newtype Region = Region' {fromRegion :: Text} + deriving stock (Show, Read, Eq, Ord, Generic) + deriving newtype + ( IsString, + Hashable, + NFData, + ToText, + FromText, + ToQuery, + ToXML, + FromXML, + ToJSON, + FromJSON, + ToByteString, + ToLog + ) + +{-# INLINE _Region #-} +_Region :: Iso' Region Text +_Region = Lens.coerced + +-- Patterns for Regions - keep in sync with +-- https://docs.aws.amazon.com/general/latest/gr/rande.html#regional-endpoints + +-- United States + +pattern Ohio :: Region +pattern Ohio = Region' "us-east-2" + +pattern NorthVirginia :: Region +pattern NorthVirginia = Region' "us-east-1" + +pattern NorthCalifornia :: Region +pattern NorthCalifornia = Region' "us-west-1" + +pattern Oregon :: Region +pattern Oregon = Region' "us-west-2" + +-- Africa + +pattern CapeTown :: Region +pattern CapeTown = Region' "af-south-1" + +-- Asia Pacific + +pattern HongKong :: Region +pattern HongKong = Region' "ap-east-1" + +pattern Hyderabad :: Region +pattern Hyderabad = Region' "ap-south-2" + +pattern Jakarta :: Region +pattern Jakarta = Region' "ap-southeast-3" + +pattern Melbourne :: Region +pattern Melbourne = Region' "ap-southeast-4" + +pattern Mumbai :: Region +pattern Mumbai = Region' "ap-south-1" + +pattern Osaka :: Region +pattern Osaka = Region' "ap-northeast-3" + +pattern Seoul :: Region +pattern Seoul = Region' "ap-northeast-2" + +pattern Singapore :: Region +pattern Singapore = Region' "ap-southeast-1" + +pattern Sydney :: Region +pattern Sydney = Region' "ap-southeast-2" + +pattern Tokyo :: Region +pattern Tokyo = Region' "ap-northeast-1" + +-- Canada + +pattern Montreal :: Region +pattern Montreal = Region' "ca-central-1" + +-- Europe + +pattern Frankfurt :: Region +pattern Frankfurt = Region' "eu-central-1" + +pattern Ireland :: Region +pattern Ireland = Region' "eu-west-1" + +pattern London :: Region +pattern London = Region' "eu-west-2" + +pattern Milan :: Region +pattern Milan = Region' "eu-south-1" + +pattern Paris :: Region +pattern Paris = Region' "eu-west-3" + +pattern Spain :: Region +pattern Spain = Region' "eu-south-2" + +pattern Stockholm :: Region +pattern Stockholm = Region' "eu-north-1" + +pattern Zurich :: Region +pattern Zurich = Region' "eu-central-2" + +-- Middle East + +pattern Bahrain :: Region +pattern Bahrain = Region' "me-south-1" + +pattern UAE :: Region +pattern UAE = Region' "me-central-1" + +-- South America + +pattern SaoPaulo :: Region +pattern SaoPaulo = Region' "sa-east-1" + +-- GovCloud + +pattern GovCloudEast :: Region +pattern GovCloudEast = Region' "us-gov-east-1" + +pattern GovCloudWest :: Region +pattern GovCloudWest = Region' "us-gov-west-1" + +-- China + +pattern Beijing :: Region +pattern Beijing = Region' "cn-north-1" + +pattern Ningxia :: Region +pattern Ningxia = Region' "cn-northwest-1" + +{-# COMPLETE + Ohio, + NorthVirginia, + NorthCalifornia, + Oregon, + CapeTown, + HongKong, + Hyderabad, + Jakarta, + Melbourne, + Mumbai, + Osaka, + Seoul, + Singapore, + Sydney, + Tokyo, + Montreal, + Frankfurt, + Ireland, + London, + Milan, + Paris, + Spain, + Stockholm, + Zurich, + Bahrain, + UAE, + SaoPaulo, + GovCloudEast, + GovCloudWest, + Beijing, + Ningxia, + Region' + #-} + +-- | A numeric value representing seconds. +newtype Seconds = Seconds DiffTime + deriving stock (Eq, Ord, Read, Show, Generic) + deriving newtype (Enum, Num, Real, NFData) + +instance Hashable Seconds where + hashWithSalt salt = hashWithSalt salt . toRational . toSeconds + +instance FromText Seconds where + fromText t = + maybe (Left err) (Right . Seconds) $ + parseTimeM False defaultTimeLocale diffTimeFormatString str + where + str = Text.unpack t + err = + "Seconds value failed to parse as expected format (" + <> diffTimeFormatString + <> "): " + <> str + +instance ToText Seconds where + toText = + Text.pack . formatTime defaultTimeLocale diffTimeFormatString . toSeconds + +_Seconds :: Iso' Seconds DiffTime +_Seconds = Lens.coerced + +-- | Format string used in parse/format options +-- +-- Currently @%Es@, which is "total seconds, with decimal point and up to +-- (default 12) decimal places, without trailing zeros. For a whole +-- number of seconds, %Es omits the decimal point unless padding is specified." +-- +-- We also use 'defaultTimeLocale', which means @0.1@ and not @0,1@. +diffTimeFormatString :: String +diffTimeFormatString = "%Es" + +instance ToByteString Seconds + +instance ToQuery Seconds + +instance ToLog Seconds where + build s = build (toText s) <> "s" + +toSeconds :: Seconds -> DiffTime +toSeconds (Seconds n) + | n < 0 = 0 + | otherwise = n + +toMicroseconds :: Seconds -> Int +toMicroseconds = round . (1000000 *) . toSeconds diff --git a/src/Amazonka/Waiter.hs b/src/Amazonka/Waiter.hs new file mode 100644 --- /dev/null +++ b/src/Amazonka/Waiter.hs @@ -0,0 +1,118 @@ +-- | +-- Module : Amazonka.Waiter +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Amazonka.Waiter + ( -- * Types + Acceptor, + Accept (..), + Wait (..), + + -- ** Lenses + wait_name, + wait_attempts, + wait_delay, + wait_acceptors, + + -- * Acceptors + accept, + + -- * Matchers + matchAll, + matchAny, + matchNonEmpty, + matchError, + matchStatus, + + -- * Util + nonEmptyText, + ) +where + +import Amazonka.Core.Lens.Internal + ( Fold, + Lens, + allOf, + anyOf, + to, + (^..), + (^?), + ) +import Amazonka.Data +import Amazonka.Error (_HttpStatus) +import Amazonka.Prelude +import Amazonka.Types +import qualified Data.Text as Text +import qualified Network.HTTP.Client as Client + +type Acceptor a = Request a -> Either Error (ClientResponse (AWSResponse a)) -> Maybe Accept + +data Accept + = AcceptSuccess + | AcceptFailure + | AcceptRetry + deriving stock (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 + { name :: ByteString, + attempts :: Int, + delay :: Seconds, + acceptors :: [Acceptor a] + } + +{-# INLINE wait_name #-} +wait_name :: Lens' (Wait a) ByteString +wait_name f w@Wait {name} = f name <&> \name' -> w {name = name'} + +{-# INLINE wait_attempts #-} +wait_attempts :: forall a. Lens' (Wait a) Int +wait_attempts f w@Wait {attempts} = f attempts <&> \attempts' -> (w :: Wait a) {attempts = attempts'} + +{-# INLINE wait_delay #-} +wait_delay :: Lens' (Wait a) Seconds +wait_delay f w@Wait {delay} = f delay <&> \delay' -> w {delay = delay'} + +{-# INLINE wait_acceptors #-} +wait_acceptors :: Lens (Wait a) (Wait b) [Acceptor a] [Acceptor b] +wait_acceptors f w@Wait {acceptors} = f acceptors <&> \acceptors' -> w {acceptors = acceptors'} + +accept :: Wait a -> Acceptor a +accept w rq rs = listToMaybe . mapMaybe (\f -> f rq rs) $ acceptors w + +matchAll :: Eq b => b -> Accept -> Fold (AWSResponse a) b -> Acceptor a +matchAll x a l = match (allOf l (== x)) a + +matchAny :: Eq b => b -> Accept -> Fold (AWSResponse a) b -> Acceptor a +matchAny x a l = match (anyOf l (== x)) a + +matchNonEmpty :: Bool -> Accept -> Fold (AWSResponse a) b -> Acceptor a +matchNonEmpty x a l = match (\rs -> null (rs ^.. l) == x) a + +matchStatus :: Int -> Accept -> Acceptor a +matchStatus x a _ = \case + Right rs | x == fromEnum (Client.responseStatus rs) -> 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 . to code -> Just a + _ -> Nothing + +match :: (AWSResponse a -> Bool) -> Accept -> Acceptor a +match f a _ = \case + Right rs | f (Client.responseBody rs) -> Just a + _ -> Nothing + +nonEmptyText :: Fold a Text -> Fold a Bool +nonEmptyText f = f . to Text.null diff --git a/src/Network/AWS/Compat/Locale.hs b/src/Network/AWS/Compat/Locale.hs deleted file mode 100644 --- a/src/Network/AWS/Compat/Locale.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | --- Module : Network.AWS.Compat.Locale --- Copyright : (c) 2013-2018 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 deleted file mode 100644 --- a/src/Network/AWS/Compat/Time.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | --- Module : Network.AWS.Compat.Time --- Copyright : (c) 2013-2018 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/Base64.hs b/src/Network/AWS/Data/Base64.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Base64.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | --- Module : Network.AWS.Data.Base64 --- Copyright : (c) 2013-2018 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.Applicative (pure) -import Control.DeepSeq -import Data.Aeson.Types -import qualified Data.Attoparsec.Text as AText -import qualified Data.ByteArray.Encoding as BA -import Data.Data (Data, Typeable) -import Data.Hashable -import qualified Data.Text.Encoding as Text -import GHC.Generics (Generic) -import Network.AWS.Data.Body -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 Network.AWS.Lens (Iso', iso) - --- | 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) - -instance Hashable Base64 -instance NFData Base64 - -_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 (pure . 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 -instance ToHashedBody Base64 where toHashed = toHashed . toBS -instance ToBody Base64 diff --git a/src/Network/AWS/Data/Body.hs b/src/Network/AWS/Data/Body.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Body.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} - -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - --- | --- Module : Network.AWS.Data.Body --- Copyright : (c) 2013-2018 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 as BS -import Data.ByteString.Builder (Builder) -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.HashMap.Strict (HashMap) -import Data.Monoid -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.Log -import Network.AWS.Data.Query (QueryString) -import Network.AWS.Data.XML (encodeXML) -import Network.AWS.Lens (AReview, Lens', lens, to, un) -import Network.HTTP.Conduit -import Text.XML (Element) - -default (Builder) - --- | A streaming, exception safe response body. -newtype RsBody = RsBody - { _streamBody :: ConduitM () ByteString (ResourceT IO) () - } -- newtype for show/orhpan instance purposes. - -instance Show RsBody where - show = const "RsBody { ConduitM () ByteString (ResourceT IO) () }" - -fuseStream :: RsBody - -> ConduitM ByteString ByteString (ResourceT IO) () - -> RsBody -fuseStream b f = b { _streamBody = _streamBody b .| f } - --- | Specifies the transmitted size of the 'Transfer-Encoding' chunks. --- --- /See:/ 'defaultChunk'. -newtype ChunkSize = ChunkSize Int - deriving (Eq, Ord, Show, Enum, Num, Real, Integral) - -instance ToLog ChunkSize where - build = build . show - --- | The default chunk size of 128 KB. The minimum chunk size accepted by --- AWS is 8 KB, unless the entirety of the request is below this threshold. --- --- A chunk size of 64 KB or higher is recommended for performance reasons. -defaultChunkSize :: ChunkSize -defaultChunkSize = 128 * 1024 - --- | An opaque request body which will be transmitted via --- @Transfer-Encoding: chunked@. --- --- /Invariant:/ Only services that support chunked encoding can --- accept a 'ChunkedBody'. (Currently S3.) This is enforced by the type --- signatures emitted by the generator. -data ChunkedBody = ChunkedBody - { _chunkedSize :: !ChunkSize - , _chunkedLength :: !Integer - , _chunkedBody :: ConduitM () ByteString (ResourceT IO) () - } - -chunkedLength :: Lens' ChunkedBody Integer -chunkedLength = lens _chunkedLength (\s a -> s { _chunkedLength = a }) - --- Maybe revert to using Source's, and then enforce the chunk size --- during conversion from HashedBody -> ChunkedBody - -instance Show ChunkedBody where - show c = BS8.unpack . toBS $ build - "ChunkedBody { chunkSize = " - <> build (_chunkedSize c) - <> "<> originalLength = " - <> build (_chunkedLength c) - <> "<> fullChunks = " - <> build (fullChunks c) - <> "<> remainderBytes = " - <> build (remainderBytes c) - <> "}" - -fuseChunks :: ChunkedBody - -> ConduitM ByteString ByteString (ResourceT IO) () - -> ChunkedBody -fuseChunks c f = c { _chunkedBody = _chunkedBody c .| f } - -fullChunks :: ChunkedBody -> Integer -fullChunks c = _chunkedLength c `div` fromIntegral (_chunkedSize c) - -remainderBytes :: ChunkedBody -> Maybe Integer -remainderBytes c = - case _chunkedLength c `mod` toInteger (_chunkedSize c) of - 0 -> Nothing - n -> Just n - --- | An opaque request body containing a 'SHA256' hash. -data HashedBody - = HashedStream (Digest SHA256) !Integer (ConduitM () ByteString (ResourceT IO) ()) - | HashedBytes (Digest SHA256) ByteString - -instance Show HashedBody where - show = \case - HashedStream h n _ -> str "HashedStream" h n - HashedBytes h x -> str "HashedBody" h (BS.length x) - where - str c h n = BS8.unpack . toBS $ - c <> " { sha256 = " - <> build (digestToBase Base16 h) - <> ", length = " - <> build n - -instance IsString HashedBody where - fromString = toHashed - -sha256Base16 :: HashedBody -> ByteString -sha256Base16 = digestToBase Base16 . \case - HashedStream h _ _ -> h - HashedBytes h _ -> h - --- | Invariant: only services that support _both_ standard and --- chunked signing expose 'RqBody' as a parameter. -data RqBody - = Chunked ChunkedBody - | Hashed HashedBody - deriving (Show) - -instance IsString RqBody where - fromString = Hashed . fromString - -md5Base64 :: RqBody -> Maybe ByteString -md5Base64 = \case - Hashed (HashedBytes _ x) -> Just . digestToBase Base64 $ hashMD5 x - _ -> Nothing - -isStreaming :: RqBody -> Bool -isStreaming = \case - Hashed (HashedStream {}) -> True - _ -> False - -toRequestBody :: RqBody -> RequestBody -toRequestBody = \case - Chunked x -> requestBodySourceChunked (_chunkedBody x) - Hashed x -> case x of - HashedStream _ n f -> requestBodySource (fromIntegral n) f - HashedBytes _ b -> RequestBodyBS b - -contentLength :: RqBody -> Integer -contentLength = \case - Chunked x -> _chunkedLength x - Hashed x -> case x of - HashedStream _ n _ -> n - HashedBytes _ b -> fromIntegral (BS.length b) - --- | Anything that can be safely converted to a 'HashedBody'. -class ToHashedBody a where - -- | Convert a value to a hashed request body. - toHashed :: a -> HashedBody - -instance ToHashedBody ByteString where - toHashed x = HashedBytes (hash x) x - -instance ToHashedBody HashedBody where toHashed = id -instance ToHashedBody String where toHashed = toHashed . LBS8.pack -instance ToHashedBody LBS.ByteString where toHashed = toHashed . toBS -instance ToHashedBody Text where toHashed = toHashed . Text.encodeUtf8 -instance ToHashedBody LText.Text where toHashed = toHashed . LText.encodeUtf8 -instance ToHashedBody Value where toHashed = toHashed . encode -instance ToHashedBody Element where toHashed = toHashed . encodeXML -instance ToHashedBody QueryString where toHashed = toHashed . toBS - -instance ToHashedBody (HashMap Text Value) where - toHashed = toHashed . Object - --- | Anything that can be converted to a streaming request 'Body'. -class ToBody a where - -- | Convert a value to a request body. - toBody :: a -> RqBody - - default toBody :: ToHashedBody a => a -> RqBody - toBody = Hashed . toHashed - -instance ToBody RqBody where toBody = id -instance ToBody HashedBody where toBody = Hashed -instance ToBody ChunkedBody where toBody = Chunked - -instance ToHashedBody a => ToBody (Maybe a) where - toBody = Hashed . maybe (toHashed BS.empty) toHashed - -instance ToBody String -instance ToBody LBS.ByteString -instance ToBody ByteString -instance ToBody Text -instance ToBody LText.Text -instance ToBody (HashMap Text Value) -instance ToBody Value -instance ToBody Element -instance ToBody QueryString - -_Body :: ToBody a => AReview RqBody a -_Body = un (to toBody) diff --git a/src/Network/AWS/Data/ByteString.hs b/src/Network/AWS/Data/ByteString.hs deleted file mode 100644 --- a/src/Network/AWS/Data/ByteString.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- Module : Network.AWS.Data.ByteString --- Copyright : (c) 2013-2018 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 - -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 deleted file mode 100644 --- a/src/Network/AWS/Data/Crypto.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} - --- | --- Module : Network.AWS.Data.Crypto --- Copyright : (c) 2013-2018 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 - , hmacSHA1 - , 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 - - --- | Apply an HMAC sha1 with the given secret to the given value. -hmacSHA1 :: (ByteArrayAccess a, ByteArray b) => a -> b -> HMAC SHA1 -hmacSHA1 = hmac - -hmacSHA256 :: (ByteArrayAccess a, ByteArray b) => a -> b -> HMAC SHA256 -hmacSHA256 = hmac - -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 deleted file mode 100644 --- a/src/Network/AWS/Data/Headers.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - --- | --- Module : Network.AWS.Data.Headers --- Copyright : (c) 2013-2018 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 - , hContentType - ) 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 - -infixl 7 .#, .#? - --- FIXME: This whole toText/fromText shit is just stupid. -(.#) :: 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" - -hExpect :: HeaderName -hExpect = "Expect" - -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" - -hAMZDecodedContentLength :: HeaderName -hAMZDecodedContentLength = "X-Amz-Decoded-Content-Length" - -hTransferEncoding :: HeaderName -hTransferEncoding = "Transfer-Encoding" - -hFormEncoded :: ByteString -hFormEncoded = "application/x-www-form-urlencoded; charset=utf-8" diff --git a/src/Network/AWS/Data/JSON.hs b/src/Network/AWS/Data/JSON.hs deleted file mode 100644 --- a/src/Network/AWS/Data/JSON.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Network.AWS.Data.JSON --- Copyright : (c) 2013-2018 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 - , eitherDecode' - - -- ** Parser a - , withObject - , (.:) - , (.:?) - , (.!=) - - -- ** Either String a - , eitherParseJSON - , (.:>) - , (.?>) - - -- * ToJSON - , ToJSON (..) - , toJSONText - , Value (Object) - , object - , (.=) - ) where - -import Data.Aeson (eitherDecode, eitherDecode') -import Data.Aeson.Types -import qualified Data.HashMap.Strict as Map -import Network.AWS.Data.Text - -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 deleted file mode 100644 --- a/src/Network/AWS/Data/List1.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Network.AWS.Data.List1 --- Copyright : (c) 2013-2018 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.DeepSeq -import Control.Monad -import Data.Aeson -import Data.Coerce -import Data.Data (Data, Typeable) -import Data.Foldable (Foldable) -import qualified Data.Foldable as Fold -import Data.Hashable -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 Network.AWS.Lens (Iso', iso) -import Text.XML (Node) - -newtype List1 a = List1 { toNonEmpty :: NonEmpty a } - deriving - ( Functor - , Monad - , Applicative - , Foldable - , Traversable - , Semigroup - , Eq - , Ord - , Read - , Show - , Data - , Typeable - , Generic - ) - -instance NFData a => NFData (List1 a) - -_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 - . Fold.toList - -instance ToJSON a => ToJSON (List1 a) where - toJSON = toJSON . toList - -instance Hashable a => Hashable (List1 a) - -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 deleted file mode 100644 --- a/src/Network/AWS/Data/Log.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -fsimpl-tick-factor=110 #-} - --- | --- Module : Network.AWS.Data.Log --- Copyright : (c) 2013-2018 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 Network.AWS.Data.ByteString -import Network.AWS.Data.Headers -import Network.AWS.Data.Path -import Network.AWS.Data.Query -import Network.AWS.Data.Text -import Network.HTTP.Conduit -import Network.HTTP.Types -import Numeric - -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 <> ">" - - 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}" - -#if MIN_VERSION_http_client(0,5,0) -instance ToLog HttpExceptionContent where - build x = "[HttpExceptionContent] {\n" <> build (show x) <> "\n}" -#endif - - -instance ToLog Request where - build x = buildLines - [ "[Client Request] {" - , " host = " <> build (host x) <> ":" <> build (port x) - , " secure = " <> build (secure x) - , " method = " <> build (method x) - , " target = " <> build target -#if MIN_VERSION_http_client(0,5,0) - , " timeout = " <> build (show (responseTimeout x)) -#else - , " timeout = " <> build (responseTimeout x) -#endif - , " redirects = " <> build (redirectCount x) - , " path = " <> build (path x) - , " query = " <> build (queryString x) - , " headers = " <> build (requestHeaders x) - , " body = " <> build (requestBody x) - , "}" - ] - where - target = hAMZTarget `lookup` requestHeaders x - -instance ToLog (Response a) where - build x = buildLines - [ "[Client Response] {" - , " status = " <> build (responseStatus x) - , " headers = " <> build (responseHeaders x) - , "}" - ] diff --git a/src/Network/AWS/Data/Map.hs b/src/Network/AWS/Data/Map.hs deleted file mode 100644 --- a/src/Network/AWS/Data/Map.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Network.AWS.Data.Map --- Copyright : (c) 2013-2018 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.DeepSeq -import Data.Aeson -import Data.Bifunctor -import qualified Data.ByteString as BS -import qualified Data.CaseInsensitive as CI -import Data.Coerce -import Data.Data (Data, Typeable) -import Data.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 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.AWS.Lens (Iso', iso) -import Network.HTTP.Types (ResponseHeaders) -import Text.XML (Node) - -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, Hashable v) => Hashable (Map k v) -instance (NFData k, NFData v) => NFData (Map k v) - -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 deleted file mode 100644 --- a/src/Network/AWS/Data/Numeric.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Network.AWS.Data.Numeric --- Copyright : (c) 2013-2018 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.DeepSeq -import Control.Monad -import Data.Aeson.Types -import Data.Data (Data, Typeable) -import Data.Hashable -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 Network.AWS.Lens (Iso', iso) -import Numeric.Natural - -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 Hashable Nat where - hashWithSalt salt (Nat n) = hashWithSalt salt (toInteger n) - -instance NFData Nat where - rnf = rnf . toInteger . unNat - -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 deleted file mode 100644 --- a/src/Network/AWS/Data/Path.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} - --- | --- Module : Network.AWS.Data.Path --- Copyright : (c) 2013-2018 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 as BS -import qualified Data.ByteString.Char8 as BS8 -import Data.Monoid (Monoid) -import Data.Semigroup (Semigroup, (<>)) -import Network.AWS.Data.ByteString -import Network.AWS.Data.Text -import Network.HTTP.Types.URI - -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 . strip . BS8.split sep . toPath - where - strip (x:xs) - | BS.null x = xs - strip xs = xs - -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 Semigroup RawPath where - Raw xs <> Raw ys = Raw (xs ++ ys) - -instance Monoid RawPath where - mempty = Raw [] - mappend = (<>) - -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 deleted file mode 100644 --- a/src/Network/AWS/Data/Query.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# 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-2018 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.Maybe (fromMaybe) -import Data.Monoid (Monoid) -import Data.Semigroup (Semigroup, (<>)) -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 - -data QueryString - = QList [QueryString] - | QPair ByteString QueryString - | QValue (Maybe ByteString) - deriving (Eq, Show, Data, Typeable) - -instance Semigroup QueryString where - 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 Monoid QueryString where - mempty = QList [] - mappend = (<>) - -instance IsString QueryString where - fromString = parseQueryString . fromString - {-# INLINE fromString #-} - -parseQueryString :: ByteString -> QueryString -parseQueryString bs - | BS8.null bs = mempty - | otherwise = - QList (map breakPair . filter (not . BS8.null) $ BS8.split '&' bs) - where - breakPair x = - case BS8.break (== '=') x of - ("", "") -> mempty - ("", v) -> stripValue v - (k, v) -> QPair k (stripValue v) - - stripValue x = - case x of - "" -> QValue Nothing - "=" -> QValue Nothing - _ -> QValue (Just (fromMaybe x (stripPrefix "=" x))) - -stripPrefix :: ByteString -> ByteString -> Maybe ByteString -#if MIN_VERSION_bytestring(0,10,8) -stripPrefix = BS8.stripPrefix -#else -stripPrefix bs1 bs2 - | bs1 `BS8.isPrefixOf` bs2 = Just (BS8.drop (BS8.length bs1) bs2) - | otherwise = Nothing -#endif - --- 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 deleted file mode 100644 --- a/src/Network/AWS/Data/Sensitive.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Network.AWS.Data.Sensitive --- Copyright : (c) 2013-2018 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.DeepSeq -import Data.Data (Data, Typeable) -import Data.Hashable -import Data.Monoid (Monoid) -import Data.Semigroup (Semigroup) -import Data.String - -import GHC.Generics (Generic) - -import Network.AWS.Data.Headers -import Network.AWS.Data.ByteString -import Network.AWS.Data.JSON -import Network.AWS.Data.Log (ToLog (..)) -import Network.AWS.Data.Query -import Network.AWS.Data.Text -import Network.AWS.Data.XML -import Network.AWS.Lens (Iso', iso) - --- | /Note/: read . show /= isomorphic -newtype Sensitive a = Sensitive { desensitise :: a } - deriving - ( Eq - , Ord - , IsString - , Semigroup - , Monoid - , Data - , Typeable - , Generic - , ToByteString - , FromText - , ToText - , FromXML - , ToXML - , ToQuery - , ToJSON - , FromJSON - , ToHeader - ) - -instance Show (Sensitive a) where show = const "******" -instance ToLog (Sensitive a) where build = const "******" - -instance Hashable a => Hashable (Sensitive a) -instance NFData a => NFData (Sensitive a) - -_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 deleted file mode 100644 --- a/src/Network/AWS/Data/Text.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} - --- | --- Module : Network.AWS.Data.Text --- Copyright : (c) 2013-2018 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 - - -- * Serialisation - , ToText (..) - , toTextCI - , showText - ) where - -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 - -class FromText a where - parser :: Parser a - -instance FromText Text where - parser = A.takeText - -instance FromText String where - parser = Text.unpack <$> A.takeText - -instance FromText ByteString where - parser = Text.encodeUtf8 <$> A.takeText - -instance (CI.FoldCase a, FromText a) => FromText (CI a) where - parser = CI.mk <$> parser - -instance FromText Char where - parser = A.anyChar <* A.endOfInput - -instance FromText Int where - parser = A.signed A.decimal <* A.endOfInput - -instance FromText Int64 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 = takeLowerText >>= \case - "true" -> pure True - "false" -> pure False - e -> fromTextError $ "Failure parsing Bool from '" <> e <> "'." - -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 deleted file mode 100644 --- a/src/Network/AWS/Data/Time.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Network.AWS.Data.Time --- Copyright : (c) 2013-2018 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.DeepSeq -import Data.Aeson -import qualified Data.Aeson.Types as 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.Hashable -import Data.Scientific -import Data.Tagged -import qualified Data.Text as Text -import Data.Time (Day (..), 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 Network.AWS.Lens (Iso', iso) - -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 - -newtype Time (a :: Format) = Time { fromTime :: UTCTime } - deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) - -instance Hashable (Time a) where - hashWithSalt salt (Time (UTCTime (ModifiedJulianDay d) t)) = - salt `hashWithSalt` d - `hashWithSalt` toRational t - -_Time :: Iso' (Time a) UTCTime -_Time = iso fromTime Time - -convert :: Time a -> Time b -convert = Time . fromTime - -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 "%XZ")) -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 = parseUnixTimestamp <|> parseFormattedTime -instance FromText AWSTime where parser = parseUnixTimestamp <|> parseFormattedTime -instance FromText RFC822 where parser = parseUnixTimestamp <|> parseFormattedTime -instance FromText ISO8601 where parser = parseUnixTimestamp <|> parseFormattedTime -instance FromText POSIX where parser = parseUnixTimestamp <|> parseFormattedTime - -parseFormattedTime :: Parser (Time a) -parseFormattedTime = do - s <- Text.unpack <$> AText.takeText - - let parse :: Tagged b String -> Parser (Time a) - parse (untag -> fmt) = - case parseTime defaultTimeLocale fmt s of - Just x -> pure (Time x) - Nothing -> - fail ( "Unable to parse Time format " - ++ show fmt - ++ " from " - ++ show s - ) - - parse (format :: Tagged RFC822 String) - <|> parse (format :: Tagged ISO8601 String) - <|> parse (format :: Tagged BasicTime String) - <|> parse (format :: Tagged AWSTime String) - -- Deprecated ISO8601 format exhibited in the AWS-supplied examples. - <|> parse (Tagged $ iso8601DateFormat (Just "%X%Q%Z")) - -- Exhaustive Failure - <|> fail ("Failure parsing Time from value: " ++ show s) - -parseUnixTimestamp :: Parser (Time a) -parseUnixTimestamp = - Time . posixSecondsToUTCTime . realToFrac - <$> AText.double <* AText.endOfInput - <|> fail "Failure parsing Unix Timestamp" - -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 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" - --- This is a somewhat unfortunate hack to support the bizzare apigateway --- occurence of returning ISO8601 or POSIX timestamps in unknown scenarios. --- --- See: https://github.com/brendanhay/amazonka/issues/291 -instance FromJSON POSIX where - parseJSON o = fmap convert (str o) <|> num o - where - str :: Value -> Aeson.Parser ISO8601 - str = parseJSON - - num :: Value -> Aeson.Parser POSIX - num = 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 ToQuery POSIX where - toQuery (Time t) = toQuery (truncate (utcTimeToPOSIXSeconds t) :: Integer) - -instance ToXML RFC822 where toXML = toXMLText -instance ToXML ISO8601 where toXML = toXMLText -instance ToXML AWSTime where toXML = toXMLText -instance ToXML BasicTime 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 deleted file mode 100644 --- a/src/Network/AWS/Data/XML.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Network.AWS.Data.XML --- Copyright : (c) 2013-2018 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.Monad - -import Data.Bifunctor -import Data.Conduit -import Data.Conduit.Lazy (lazyConsume) -import Data.Maybe -import Data.Monoid (Monoid) -import Data.Semigroup (Semigroup, (<>)) -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 Text.XML.Unresolved (toEvents) - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Conduit.List as Conduit -import qualified Text.XML.Stream.Render as Stream - -infixl 7 .@, .@? - -(.@) :: FromXML a => [Node] -> Text -> Either String a -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 - -(@@=) :: ToText a => Name -> a -> XML -n @@= x = XAttr n (toText x) - -decodeXML :: FromXML a => LazyByteString -> Either String a -decodeXML lbs = - bimap show documentRoot (parseLBS def lbs) - >>= parseXML . childrenOf - --- The following is taken from xml-conduit.Text.XML which uses --- unsafePerformIO anyway, with the following caveat: --- '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 - --- | Convert to an 'Element', only if the resulting element contains @> 0@ nodes. -maybeElement :: ToElement a => a -> Maybe Element -maybeElement x = - case toElement x of - e@(Element _ _ ns) - | null ns -> Nothing - | otherwise -> Just e - --- | Provides a way to make the operators for ToXML instance --- declaration be consistent WRT to single nodes or lists of nodes. -data XML - = XNull - | XAttr Name Text - | XOne Node - | XMany [(Name, Text)] [Node] - deriving (Show) - -instance Semigroup XML where - XNull <> XNull = XNull - a <> XNull = a - XNull <> b = b - a <> b = - XMany (listXMLAttributes a <> listXMLAttributes b) - (listXMLNodes a <> listXMLNodes b) - -instance Monoid XML where - mempty = XNull - mappend = (<>) - -listXMLNodes :: XML -> [Node] -listXMLNodes = \case - XNull -> [] - XAttr {} -> [] - XOne n -> [n] - XMany _ ns -> ns - -listXMLAttributes :: XML -> [(Name, Text)] -listXMLAttributes = \case - XNull -> [] - XAttr n t -> [(n, t)] - XOne {} -> [] - XMany as _ -> as - -class ToXML a where - toXML :: a -> XML - -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 (toXML -> x) = - Element n (fromList (listXMLAttributes x)) (listXMLNodes x) - -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 - --- | Find a specific named NodeElement, at the current depth in the node tree. --- --- Fails if absent. -findElement :: Text -> [Node] -> Either String [Node] -findElement n ns = - missingElement n ns - . listToMaybe - $ mapMaybe (childNodesOf n) ns - --- | Find the first specific named NodeElement, at any depth in the node tree. --- --- Fails if absent. -firstElement :: Text -> [Node] -> Either String [Node] -firstElement n ns = - missingElement n ns - . listToMaybe - $ mapMaybe go ns - where - go x = case x of - NodeElement e - | Just n == localName x -> Just (childrenOf e) - | otherwise -> listToMaybe (mapMaybe go (elementNodes e)) - _ -> Nothing - -childNodesOf :: Text -> Node -> Maybe [Node] -childNodesOf n x = case x of - NodeElement e - | Just n == localName x - -> Just (childrenOf e) - _ -> Nothing - -childrenOf :: Element -> [Node] -childrenOf e = elementNodes e <> map node (toList (elementAttributes e)) - where - node (k, v) = NodeElement (Element (name k) mempty [NodeContent v]) - - name k = Name - { nameLocalName = fromMaybe "" (namePrefix k) <> ":" <> nameLocalName k - , nameNamespace = mempty - , namePrefix = mempty - } - -localName :: Node -> Maybe Text -localName = \case - NodeElement e -> Just (nameLocalName (elementName e)) - _ -> Nothing - --- | An inefficient mechanism for retreiving the root --- element name of an XML document. -rootElementName :: LazyByteString -> Maybe Text -rootElementName bs = - either (const Nothing) - (Just . nameLocalName . elementName . documentRoot) - (parseLBS def bs) - -missingElement :: Text -> [Node] -> Maybe a -> Either String a -missingElement n ns = maybe (Left err) Right - where - err = "unable to find element " - ++ show n - ++ " in nodes " - ++ show (mapMaybe localName ns) diff --git a/src/Network/AWS/Endpoint.hs b/src/Network/AWS/Endpoint.hs deleted file mode 100644 --- a/src/Network/AWS/Endpoint.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Network.AWS.Types --- Copyright : (c) 2013-2018 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.Lens ((%~), (.~)) -import Network.AWS.Types - --- | A convenience function for overriding the 'Service' 'Endpoint'. --- --- /See:/ 'serviceEndpoint'. -setEndpoint :: Bool -- ^ Whether to use HTTPS (ie. SSL). - -> ByteString -- ^ The hostname to connect to. - -> Int -- ^ The port number to connect to. - -> Service -- ^ The service configuration to override. - -> Service -setEndpoint s h p = serviceEndpoint %~ addr - where - addr = (endpointSecure .~ s) - . (endpointHost .~ h) - . (endpointPort .~ p) - --- | Determine the full host address and credential scope --- within the specified 'Region'. -defaultEndpoint :: Service -> Region -> Endpoint -defaultEndpoint (_svcPrefix -> p) r = go (CI.mk p) - 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" - - "waf" - | not china -> global "waf.amazonaws.com" - - _ | china -> region (p <> "." <> reg <> ".amazonaws.com.cn") - | otherwise -> region (p <> "." <> 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 - , _endpointSecure = True - , _endpointPort = 443 - , _endpointScope = reg - } - - global h = Endpoint - { _endpointHost = h - , _endpointSecure = True - , _endpointPort = 443 - , _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 deleted file mode 100644 --- a/src/Network/AWS/Error.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE CPP #-} - --- | --- Module : Network.AWS.Error --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.AWS.Error where - -import Control.Applicative -import Control.Monad - -import Data.Aeson -import Data.Aeson.Types (parseEither) -import Data.Maybe -import Data.Monoid - -import Network.AWS.Data.ByteString -import Network.AWS.Data.Headers -import Network.AWS.Data.Text -import Network.AWS.Data.XML -import Network.AWS.Lens (Choice, Getting, Optic', filtered) -import Network.AWS.Types -import Network.HTTP.Conduit -import Network.HTTP.Types.Status (Status (..)) - -import qualified Data.ByteString.Lazy as LBS - --- | Provides a generalised prism for catching a specific service error --- identified by the opaque service abbreviation and error code. --- --- This can be used if the generated error prisms provided by --- @Network.AWS..Types@ do not cover all the thrown error codes. --- For example to define a new error prism: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Network.AWS.S3 (ServiceError, s3) --- > --- > _NoSuchBucketPolicy :: AsError a => Getting (First ServiceError) a ServiceError --- > _NoSuchBucketPolicy = _MatchServiceError s3 "NoSuchBucketPolicy" --- --- With example usage being: --- --- >>> import Control.Exception.Lens (trying) --- >>> :t trying _NoSuchBucketPolicy --- MonadCatch m => m a -> m (Either ServiceError a) -_MatchServiceError :: AsError a - => Service - -> ErrorCode - -> Getting (First ServiceError) a ServiceError -_MatchServiceError s c = _ServiceError . hasService s . hasCode c - -statusSuccess :: Status -> Bool -statusSuccess (statusCode -> n) = n >= 200 && n < 300 - -httpStatus :: AsError a => Getting (First Status) a Status -httpStatus = _Error . f - where - f g = \case -#if MIN_VERSION_http_client(0,5,0) - TransportError (HttpExceptionRequest rq (StatusCodeException rs b)) - -> (\x -> TransportError (HttpExceptionRequest rq (StatusCodeException (rs { responseStatus = x }) b))) - <$> g (responseStatus rs) -#else - TransportError (StatusCodeException s h c) - -> TransportError <$> (StatusCodeException <$> g s <*> pure h <*> pure c) -#endif - TransportError e - -> pure (TransportError e) - - SerializeError (SerializeError' a s b e) - -> (\x -> SerializeError (SerializeError' a x b e)) <$> g s - - ServiceError e - -> (\x -> ServiceError (e { _serviceStatus = x })) - <$> g (_serviceStatus e) - -hasService :: (Applicative f, Choice p) - => Service - -> Optic' p f ServiceError ServiceError -hasService s = filtered ((_svcAbbrev s ==) . _serviceAbbrev) - -hasStatus :: (Applicative f, Choice p) - => Int - -> Optic' p f ServiceError ServiceError -hasStatus n = filtered ((n ==) . fromEnum . _serviceStatus) - -hasCode :: (Applicative f, Choice p) - => ErrorCode - -> Optic' p f ServiceError ServiceError -hasCode c = filtered ((c ==) . _serviceCode) - -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) - -getRequestId :: [Header] -> Maybe RequestId -getRequestId h = - either (const Nothing) Just (h .# hAMZRequestId <|> h .# hAMZNRequestId) - -getErrorCode :: Status -> [Header] -> ErrorCode -getErrorCode s h = - case h .# hAMZNErrorType of - Left _ -> errorCode (toText (statusMessage s)) - Right x -> errorCode x - -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) - - go o = do - e <- (Just <$> o .: "__type") <|> o .:? "code" - m <- msg e o - return $! serviceError a s h e m Nothing - - msg c o = - if c == Just "RequestEntityTooLarge" - then pure (Just "Request body must be less than 1 MB") - else Just <$> o .: "message" - <|> o .:? "Message" - -parseXMLError :: Abbrev - -> Status - -> [Header] - -> LazyByteString - -> Error -parseXMLError a s h bs = decodeError a s h bs (decodeXML bs >>= go) - where - go x = serviceError a s h - <$> code x - <*> may (firstElement "Message" x) - <*> may (firstElement "RequestId" x <|> firstElement "RequestID" x) - - code x = Just <$> (firstElement "Code" x >>= parseXML) - <|> return root - - root = errorCode <$> rootElementName bs - - may (Left _) = pure Nothing - may (Right x) = Just <$> parseXML x - -parseRESTError :: Abbrev - -> Status - -> [Header] - -> a - -> Error -parseRESTError a s h _ = - ServiceError (serviceError a s h Nothing Nothing Nothing) - -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 (Just bs)) - ServiceError - e diff --git a/src/Network/AWS/Lens.hs b/src/Network/AWS/Lens.hs deleted file mode 100644 --- a/src/Network/AWS/Lens.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | --- Module : Network.AWS.Lens --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.AWS.Lens - ( module Ex - , module Ty - , module Fn - , module Op - ) where - -import Control.Exception.Lens as Ex (catching, catching_, exception, - throwingM, trying, _IOException) -import Control.Lens as Ty (AReview, Choice, Fold, Getter, - Getting, IndexedTraversal', Iso', - Lens', Optic', Prism', Setter', - Traversal') -import Control.Lens as Fn (allOf, anyOf, concatOf, filtered, - folding, has, iso, lens, mapping, - prism, sets, to, traversed, un, - view, _1, _2, _Just, _last) -import Control.Lens as Op (( # ), (%~), (&), (.~), (<&>), - (<>~), (?~), (^.), (^?)) diff --git a/src/Network/AWS/Pager.hs b/src/Network/AWS/Pager.hs deleted file mode 100644 --- a/src/Network/AWS/Pager.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Module : Network.AWS.Pager --- Copyright : (c) 2013-2018 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 Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map -import Data.Maybe (isJust, fromMaybe) -import Data.Text (Text) -import Network.AWS.Data.Text (ToText (..)) -import Network.AWS.Lens (Getter, to) -import Network.AWS.Types - --- | 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 [a] where - truncated = not . null - -instance AWSTruncated (HashMap k v) where - truncated = not . Map.null - -instance {-# OVERLAPPABLE #-} AWSTruncated (Maybe a) where - truncated = isJust - -instance {-# OVERLAPS #-} AWSTruncated (Maybe Bool) where - truncated = fromMaybe False - -stop :: AWSTruncated a => a -> Bool -stop = not . truncated - -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/Prelude.hs b/src/Network/AWS/Prelude.hs deleted file mode 100644 --- a/src/Network/AWS/Prelude.hs +++ /dev/null @@ -1,60 +0,0 @@ --- | --- Module : Network.AWS.Prelude --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.AWS.Prelude - ( module Network.AWS.Prelude - , module Export - ) where - -import Control.Applicative as Export (Applicative, pure) -import Control.Applicative as Export ((<$>), (<*>), (<|>)) -import Control.DeepSeq as Export (NFData) -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 Data.Monoid as Export ((<>)) -import GHC.Generics as Export (Generic) -import Network.HTTP.Types.Status as Export (Status (..)) -import Network.HTTP.Types.URI as Export (urlDecode, urlEncode) -import Numeric.Natural as Export (Natural) - -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 (AWSTime, BasicTime, ISO8601, - POSIX, RFC822, Time (..), UTCTime, - _Time) -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 (Algorithm, Endpoint, - LogLevel (..), Seconds, Signer, - serviceEndpoint) - -infixl 7 .!@ - -(.!@) :: 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 deleted file mode 100644 --- a/src/Network/AWS/Request.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Network.AWS.Request --- Copyright : (c) 2013-2018 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 - , patchJSON - - , postXML - , postJSON - , postQuery - , postBody - - , putXML - , putJSON - , putBody - - -- ** Constructors - , defaultRequest - - -- ** Operation Plugins - , contentMD5Header - , expectHeader - - -- ** Lenses - , requestHeaders - , queryString - , requestURL - ) where - -import Data.Maybe -import Data.Monoid -import Network.AWS.Data.Body -import Network.AWS.Data.ByteString -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.Lens (Lens') -import Network.AWS.Lens ((%~), (&), (.~), (<&>)) -import Network.AWS.Types -import qualified Network.HTTP.Conduit as Client -import Network.HTTP.Types (StdMethod (..)) -import qualified Network.HTTP.Types as HTTP - -type ToRequest a = (ToPath a, ToQuery a, ToHeaders a) - -head' :: ToRequest a => Service -> a -> Request a -head' s x = get s x & rqMethod .~ HEAD - -delete :: ToRequest a => Service -> a -> Request a -delete s x = get s x & rqMethod .~ DELETE - -get :: ToRequest a => Service -> a -> Request a -get s = defaultRequest s - -post :: ToRequest a => Service -> a -> Request a -post s x = get s x & rqMethod .~ POST - -put :: ToRequest a => Service -> a -> Request a -put s x = get s x & rqMethod .~ PUT - -patchJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a -patchJSON s x = putJSON s x & rqMethod .~ PATCH - -postXML :: (ToRequest a, ToElement a) => Service -> a -> Request a -postXML s x = putXML s x & rqMethod .~ POST - -postJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a -postJSON s x = putJSON s x & rqMethod .~ POST - -postQuery :: ToRequest a => Service -> a -> Request a -postQuery s x = Request - { _rqService = s - , _rqMethod = POST - , _rqPath = rawPath x - , _rqQuery = mempty - , _rqBody = toBody (toQuery x) - , _rqHeaders = hdr hContentType hFormEncoded (toHeaders x) - } - -postBody :: (ToRequest a, ToBody a) => Service -> a -> Request a -postBody s x = defaultRequest s x - & rqMethod .~ POST - & rqBody .~ toBody x - -putXML :: (ToRequest a, ToElement a) => Service -> a -> Request a -putXML s x = defaultRequest s x - & rqMethod .~ PUT - & rqBody .~ maybe "" toBody (maybeElement x) - -putJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a -putJSON s x = defaultRequest s x - & rqMethod .~ PUT - & rqBody .~ toBody (toJSON x) - -putBody :: (ToRequest a, ToBody a) => Service -> a -> Request a -putBody s x = defaultRequest s x - & rqMethod .~ PUT - & rqBody .~ toBody x - -defaultRequest :: ToRequest a => Service -> a -> Request a -defaultRequest s x = Request - { _rqService = s - , _rqMethod = GET - , _rqPath = rawPath x - , _rqQuery = toQuery x - , _rqHeaders = toHeaders x - , _rqBody = "" - } - -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 - <> toBS (Client.host x) - <> port (Client.port x) - <> toBS (Client.path x) - <> toBS (Client.queryString x) - where - scheme - | secure = "https://" - | otherwise = "http://" - - port = \case - 80 -> "" - 443 | secure -> "" - n -> ":" <> toBS n - - secure = Client.secure x - -contentMD5Header :: Request a -> Request a -contentMD5Header rq - | missing, Just x <- md5 = rq & rqHeaders %~ hdr HTTP.hContentMD5 x - | otherwise = rq - where - missing = isNothing $ lookup HTTP.hContentMD5 (_rqHeaders rq) - md5 = md5Base64 (_rqBody rq) - -expectHeader :: Request a -> Request a -expectHeader = rqHeaders %~ hdr hExpect "100-continue" diff --git a/src/Network/AWS/Response.hs b/src/Network/AWS/Response.hs deleted file mode 100644 --- a/src/Network/AWS/Response.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Network.AWS.Response --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.AWS.Response where - -import Control.Applicative (pure) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource - -import Data.Aeson -import Data.Conduit -import Data.Monoid -import Data.Proxy -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.Conduit hiding (Proxy, Request, Response) -import Network.HTTP.Types - -import Text.XML (Node) - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Conduit.Binary as Conduit - -receiveNull :: (MonadResource m, MonadThrow m) - => Rs a - -> Logger - -> Service - -> Proxy a - -> ClientResponse - -> m (Response a) -receiveNull rs _ = stream $ \_ _ x -> - liftResourceT (x `connect` pure (Right rs)) - -receiveEmpty :: (MonadResource m, MonadThrow m) - => (Int -> ResponseHeaders -> () -> Either String (Rs a)) - -> Logger - -> Service - -> Proxy a - -> ClientResponse - -> m (Response a) -receiveEmpty f _ = stream $ \s h x -> - liftResourceT (x `connect` pure (f s h ())) - -receiveXMLWrapper :: (MonadResource m, MonadThrow m) - => Text - -> (Int -> ResponseHeaders -> [Node] -> Either String (Rs a)) - -> Logger - -> Service - -> Proxy a - -> ClientResponse - -> m (Response a) -receiveXMLWrapper n f = receiveXML (\s h x -> x .@ n >>= f s h) - -receiveXML :: (MonadResource m, MonadThrow m) - => (Int -> ResponseHeaders -> [Node] -> Either String (Rs a)) - -> Logger - -> Service - -> Proxy a - -> ClientResponse - -> m (Response a) -receiveXML = deserialise decodeXML - -receiveJSON :: (MonadResource m, MonadThrow m) - => (Int -> ResponseHeaders -> Object -> Either String (Rs a)) - -> Logger - -> Service - -> Proxy a - -> ClientResponse - -> m (Response a) -receiveJSON = deserialise eitherDecode' - -receiveBytes :: (MonadResource m, MonadThrow m) - => (Int -> ResponseHeaders -> ByteString -> Either String (Rs a)) - -> Logger - -> Service - -> Proxy a - -> ClientResponse - -> m (Response a) -receiveBytes = deserialise (Right . LBS.toStrict) - -receiveBody :: (MonadResource m, MonadThrow m) - => (Int -> ResponseHeaders -> RsBody -> Either String (Rs a)) - -> Logger - -> Service - -> Proxy a - -> ClientResponse - -> m (Response a) -receiveBody f _ = stream $ \s h x -> pure (f s h (RsBody x)) - --- | Deserialise an entire response body, such as an XML or JSON payload. -deserialise :: (MonadResource m, MonadThrow m) - => (LazyByteString -> Either String b) - -> (Int -> ResponseHeaders -> b -> Either String (Rs a)) - -> Logger - -> Service - -> Proxy a - -> ClientResponse - -> m (Response a) -deserialise g f l Service{..} _ rs = do - let s = responseStatus rs - h = responseHeaders rs - x = responseBody rs - b <- sinkLBS x - if not (_svcCheck s) - then throwM (_svcError s h b) - else do - liftIO . l Debug . build $ "[Raw Response Body] {\n" <> b <> "\n}" - case g b >>= f (fromEnum s) h of - Right r -> pure (s, r) - Left e -> throwM . SerializeError $ - SerializeError' _svcAbbrev s (Just b) e - --- | Stream a raw response body, such as an S3 object payload. -stream :: (MonadResource m, MonadThrow m) - => (Int -> ResponseHeaders -> ResponseBody -> m (Either String (Rs a))) - -> Service - -> Proxy a - -> ClientResponse - -> m (Response a) -stream f Service{..} _ rs = do - let s = responseStatus rs - h = responseHeaders rs - x = responseBody rs - if not (_svcCheck s) - then sinkLBS x >>= throwM . _svcError s h - else do - e <- f (fromEnum s) h x - either (throwM . SerializeError . SerializeError' _svcAbbrev s Nothing) - (pure . (s,)) - e - -sinkLBS :: MonadResource m => ResponseBody -> m LazyByteString -sinkLBS bdy = liftResourceT (bdy `connect` Conduit.sinkLbs) diff --git a/src/Network/AWS/Sign/V2.hs b/src/Network/AWS/Sign/V2.hs deleted file mode 100644 --- a/src/Network/AWS/Sign/V2.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Network.AWS.Sign.V2 --- Copyright : (c) 2013-2018 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 - ) where - -import qualified Data.ByteString.Char8 as BS8 -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.Conduit as Client -import Network.HTTP.Types hiding (toQuery) - -data V2 = V2 - { metaTime :: !UTCTime - , metaEndpoint :: !Endpoint - , metaSignature :: !ByteString - } - -instance ToLog V2 where - build V2{..} = buildLines - [ "[Version 2 Metadata] {" - , " time = " <> build metaTime - , " endpoint = " <> build (_endpointHost metaEndpoint) - , " signature = " <> build metaSignature - , "}" - ] - -v2 :: Signer -v2 = Signer sign (const sign) -- FIXME: revisit v2 presigning. - -sign :: Algorithm a -sign Request{..} AuthEnv{..} r t = Signed meta rq - where - meta = Meta (V2 t end signature) - - rq = (clientRequest end _svcTimeout) - { Client.method = meth - , Client.path = path' - , Client.queryString = toBS authorised - , Client.requestHeaders = headers - , Client.requestBody = toRequestBody _rqBody - } - - meth = toBS _rqMethod - path' = toBS (escapePath _rqPath) - - end@Endpoint{..} = _svcEndpoint r - - Service{..} = _rqService - - 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/V2Header.hs b/src/Network/AWS/Sign/V2Header.hs deleted file mode 100644 --- a/src/Network/AWS/Sign/V2Header.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- Module : Network.AWS.Sign.V2Header --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- This module provides an AWS compliant V2 Header request signer. It is based --- heavily on boto (https://github.com/boto/boto), specifically boto's --- @HmacAuthV1Handler@ AWS capable signer. AWS documentation is available --- . --- --- /Notice/: Limitations include an inability to sign with a security token and --- inability to overwrite the @Date@ header with an expiry. -module Network.AWS.Sign.V2Header - ( v2Header - ) where - -import Data.Monoid -import Data.Time -import Network.AWS.Data.Body -import Network.AWS.Data.ByteString -import Network.AWS.Data.Crypto -import Network.AWS.Data.Headers -import Network.AWS.Data.Log -import Network.AWS.Data.Path -import Network.AWS.Data.Time -import qualified Network.AWS.Sign.V2Header.Base as V2 -import Network.AWS.Types -import qualified Network.HTTP.Conduit as Client -import Network.HTTP.Types - -data V2Header = V2Header - { metaTime :: !UTCTime - , metaEndpoint :: !Endpoint - , metaSignature :: !ByteString - , headers :: !Network.HTTP.Types.RequestHeaders - , signer :: !ByteString - } - -instance ToLog V2Header where - build V2Header{..} = buildLines - [ "[Version 2 Header Metadata] {" - , " time = " <> build metaTime - , " endpoint = " <> build (_endpointHost metaEndpoint) - , " signature = " <> build metaSignature - , " headers = " <> build headers - , " signer = " <> build signer - , "}" - ] - -v2Header :: Signer -v2Header = Signer sign (const sign) - -sign :: Algorithm a -sign Request{..} AuthEnv{..} r t = Signed meta rq - where - meta = Meta (V2Header t end signature headers signer) - - signer = V2.newSigner headers meth path' _rqQuery - - rq = (clientRequest end _svcTimeout) - { Client.method = meth - , Client.path = path' - , Client.queryString = toBS _rqQuery - , Client.requestHeaders = headers - , Client.requestBody = toRequestBody _rqBody - } - - meth = toBS _rqMethod - path' = toBS (escapePath _rqPath) - - end@Endpoint{..} = _svcEndpoint r - - Service{..} = _rqService - - signature = digestToBase Base64 - . hmacSHA1 (toBS _authSecret) $ signer - - headers = - hdr hDate time - . hdr hAuthorization ("AWS " <> toBS _authAccess <> ":" <> signature) - $ _rqHeaders - - time = toBS (Time t :: RFC822) diff --git a/src/Network/AWS/Sign/V2Header/Base.hs b/src/Network/AWS/Sign/V2Header/Base.hs deleted file mode 100644 --- a/src/Network/AWS/Sign/V2Header/Base.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Network.AWS.Sign.V2Header.Base --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- This module provides auxiliary functions necessary for the AWS compliant V2 --- Header request signer. --- /See/: "Network.AWS.Sign.V2Header" -module Network.AWS.Sign.V2Header.Base - ( newSigner - - -- * Testing - , toSignerQueryBS - - , constructSigningHeader - , constructSigningQuery - , constructFullPath - - , unionNecessaryHeaders - ) where - -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as Build -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.CaseInsensitive as CI -import Data.Function (on) -import qualified Data.List as List -import Data.Monoid (mempty, (<>)) -import qualified Network.AWS.Data.Query as Query -import qualified Network.HTTP.Types as HTTP -import Network.HTTP.Types.URI (urlEncode) - --- | Construct a full header signer following the V2 Header scheme -newSigner :: HTTP.RequestHeaders - -> ByteString - -> ByteString - -> Query.QueryString - -> ByteString -newSigner headers method path query = signer - where - signer = - BS8.intercalate "\n" - ( method - : map constructSigningHeader (List.sort filteredHeaders) - ++ [constructFullPath path (toSignerQueryBS filteredQuery)] - ) - - filteredHeaders = unionNecessaryHeaders (filter isInterestingHeader headers) - - filteredQuery = constructSigningQuery query - --- | The following function mostly follows the toBS in amazonka QueryString --- except for single QValue or single QPair keys not being suffixed with --- an equals. -toSignerQueryBS :: Query.QueryString -> ByteString -toSignerQueryBS = - LBS.toStrict . Build.toLazyByteString . cat . List.sort . enc Nothing - where - enc :: Maybe ByteString -> Query.QueryString -> [ByteString] - enc p = \case - Query.QList xs -> concatMap (enc p) xs - - Query.QPair (urlEncode True -> k) x - | Just n <- p -> enc (Just (n <> kdelim <> k)) x -- .key - | otherwise -> enc (Just k) x -- key - - Query.QValue (Just (urlEncode True -> v)) - | Just n <- p -> [n <> vsep <> v] -- key=value - | otherwise -> [v] - - _ | Just n <- p -> [n] - | otherwise -> [] - - cat :: [ByteString] -> Builder - cat [] = mempty - cat [x] = Build.byteString x - cat (x:xs) = Build.byteString x <> ksep <> cat xs - - kdelim = "." - ksep = "&" - vsep = "=" - -hasAWSPrefix :: CI.CI ByteString -> Bool -hasAWSPrefix = BS8.isPrefixOf "aws-" . CI.foldedCase - --- | Filter for 'interesting' keys within a QueryString -isInterestingQueryKey :: ByteString -> Bool -isInterestingQueryKey = \case - "acl" -> True - "cors" -> True - "defaultObjectAcl" -> True - "location" -> True - "logging" -> True - "partNumber" -> True - "policy" -> True - "requestPayment" -> True - "torrent" -> True - "versioning" -> True - "versionId" -> True - "versions" -> True - "website" -> True - "uploads" -> True - "uploadId" -> True - "response-content-type" -> True - "response-content-language" -> True - "response-expires" -> True - "response-cache-control" -> True - "response-content-disposition" -> True - "response-content-encoding" -> True - "delete" -> True - "lifecycle" -> True - "tagging" -> True - "restore" -> True - "storageClass" -> True - "websiteConfig" -> True - "compose" -> True - _ -> False - --- | Filter for 'interesting' header fields -isInterestingHeader :: HTTP.Header -> Bool -isInterestingHeader (name, _) - | name == HTTP.hDate = True - | name == HTTP.hContentMD5 = True - | name == HTTP.hContentType = True - | hasAWSPrefix name = True - | otherwise = False - --- | Constructs a query string for signing -constructSigningQuery :: Query.QueryString -> Query.QueryString -constructSigningQuery = \case - Query.QValue {} -> Query.QValue Nothing - Query.QList qs -> Query.QList (map constructSigningQuery qs) - Query.QPair k v - | isInterestingQueryKey k -> Query.QPair k v - | otherwise -> Query.QValue Nothing - --- | Construct a header string for signing -constructSigningHeader :: HTTP.Header -> ByteString -constructSigningHeader (name, value) - | hasAWSPrefix name = CI.foldedCase name <> ":" <> value - | otherwise = value - -constructFullPath :: ByteString -> ByteString -> ByteString -constructFullPath path q - | BS8.null q = path - | otherwise = path <> "?" <> q - -unionNecessaryHeaders :: [HTTP.Header] -> [HTTP.Header] -unionNecessaryHeaders = - flip (List.unionBy (on (==) fst)) - [ (HTTP.hContentMD5, "") - , (HTTP.hContentType, "") - ] diff --git a/src/Network/AWS/Sign/V4.hs b/src/Network/AWS/Sign/V4.hs deleted file mode 100644 --- a/src/Network/AWS/Sign/V4.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Network.AWS.Sign.V4 --- Copyright : (c) 2013-2018 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 (..) - , v4 - ) where - -import qualified Data.CaseInsensitive as CI -import Data.Monoid -import Network.AWS.Data.Body -import Network.AWS.Data.ByteString -import Network.AWS.Data.Headers -import Network.AWS.Data.Query -import Network.AWS.Data.Time -import Network.AWS.Lens ((%~), (<>~)) -import Network.AWS.Request -import Network.AWS.Sign.V4.Base -import Network.AWS.Sign.V4.Chunked -import Network.AWS.Types - -default (ByteString) - -v4 :: Signer -v4 = Signer sign presign - -presign :: Seconds -> Algorithm a -presign ex rq a r ts = signRequest meta mempty auth - where - auth = queryString <>~ ("&X-Amz-Signature=" <> toBS (metaSignature meta)) - - meta = signMetadata a r ts presigner digest (prepare rq) - - presigner 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 a) - - digest = Tag "UNSIGNED-PAYLOAD" - - prepare = rqHeaders %~ ( hdr hHost (_endpointHost end) ) - end = _svcEndpoint (_rqService rq) r - -sign :: Algorithm a -sign rq a r ts = - case _rqBody rq of - Chunked x -> chunked x rq a r ts - Hashed x -> hashed x rq a r ts - -hashed :: HashedBody -> Algorithm a -hashed x rq a r ts = - let (meta, auth) = base (Tag (sha256Base16 x)) rq a r ts - in signRequest meta (toRequestBody (Hashed x)) auth diff --git a/src/Network/AWS/Sign/V4/Base.hs b/src/Network/AWS/Sign/V4/Base.hs deleted file mode 100644 --- a/src/Network/AWS/Sign/V4/Base.hs +++ /dev/null @@ -1,269 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Network.AWS.Sign.V4.Base --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.AWS.Sign.V4.Base where - -import Data.Bifunctor -import Data.Function (on) -import Data.List (nubBy, sortBy) -import Data.Monoid - -import GHC.TypeLits - -import Network.AWS.Data.ByteString -import Network.AWS.Data.Crypto -import Network.AWS.Data.Headers -import Network.AWS.Data.Log -import Network.AWS.Data.Path -import Network.AWS.Data.Query -import Network.AWS.Data.Sensitive (_Sensitive) -import Network.AWS.Data.Time -import Network.AWS.Lens ((%~), (<>~), (^.)) -import Network.AWS.Request -import Network.AWS.Types - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.CaseInsensitive as CI -import qualified Data.Foldable as Fold -import qualified Network.HTTP.Conduit as Client -import qualified Network.HTTP.Types.Header as H - -default (ByteString) - -data V4 = V4 - { metaTime :: !UTCTime - , metaMethod :: !Method - , metaPath :: !Path - , metaEndpoint :: !Endpoint - , metaCredential :: !Credential - , metaCanonicalQuery :: !CanonicalQuery - , metaCanonicalRequest :: !CanonicalRequest - , metaCanonicalHeaders :: !CanonicalHeaders - , metaSignedHeaders :: !SignedHeaders - , metaStringToSign :: !StringToSign - , metaSignature :: !Signature - , metaHeaders :: ![Header] - , metaTimeout :: !(Maybe Seconds) - } - -instance ToLog V4 where - build V4{..} = 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 - , " }" - , "}" - ] - -base :: Hash - -> Request a - -> AuthEnv - -> Region - -> UTCTime - -> (V4, ClientRequest -> ClientRequest) -base h rq a r ts = (meta, auth) - where - auth = requestHeaders <>~ [(H.hAuthorization, authorisation meta)] - - meta = signMetadata a r ts presigner h (prepare rq) - - presigner _ _ = id - - prepare = rqHeaders %~ - ( hdr hHost (_endpointHost end) - . hdr hAMZDate (toBS (Time ts :: AWSTime)) - . hdr hAMZContentSHA256 (toBS h) - . maybe id (hdr hAMZToken . toBS) (_authToken a) - ) - - end = _svcEndpoint (_rqService rq) r - --- | 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 } deriving (Show) - -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 :: V4 -> ByteString -authorisation V4{..} = algorithm - <> " Credential=" <> toBS metaCredential - <> ", SignedHeaders=" <> toBS metaSignedHeaders - <> ", Signature=" <> toBS metaSignature - -signRequest :: V4 -- ^ Pre-signRequestd signing metadata. - -> Client.RequestBody -- ^ The request body. - -> (ClientRequest -> ClientRequest) -- ^ Insert authentication information. - -> Signed a -signRequest m@V4{..} b auth = Signed (Meta m) (auth rq) - where - rq = (clientRequest metaEndpoint metaTimeout) - { Client.method = toBS metaMethod - , Client.path = toBS metaPath - , Client.queryString = qry - , Client.requestHeaders = metaHeaders - , Client.requestBody = b - } - - qry | BS.null x = x - | otherwise = '?' `BS8.cons` x - where - x = toBS metaCanonicalQuery - -signMetadata :: AuthEnv - -> Region - -> UTCTime - -> (Credential -> SignedHeaders -> QueryString -> QueryString) - -> Hash - -> Request a - -> V4 -signMetadata a r ts presign digest rq = V4 - { metaTime = ts - , metaMethod = method - , metaPath = path - , metaEndpoint = end - , metaCredential = cred - , metaCanonicalQuery = query - , metaCanonicalRequest = crq - , metaCanonicalHeaders = chs - , metaSignedHeaders = shs - , metaStringToSign = sts - , metaSignature = signature (_authSecret a ^. _Sensitive) scope sts - , metaHeaders = _rqHeaders rq - , metaTimeout = _svcTimeout svc - } - where - query = canonicalQuery . presign cred shs $ _rqQuery rq - - sts = stringToSign ts scope crq - cred = credential (_authAccess a) 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 r - method = Tag . toBS $ _rqMethod rq - path = escapedPath rq - - svc = _rqService 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 -> 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 :: Request a -> Path -escapedPath r = Tag . toBS . escapePath $ - case _svcAbbrev (_rqService r) 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/Sign/V4/Chunked.hs b/src/Network/AWS/Sign/V4/Chunked.hs deleted file mode 100644 --- a/src/Network/AWS/Sign/V4/Chunked.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - --- | --- Module : Network.AWS.Sign.V4.Chunked --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.AWS.Sign.V4.Chunked - ( chunked - ) where - -import Data.ByteString.Builder -import Data.Conduit -import Data.Maybe -import Data.Monoid - -import Network.AWS.Data.Body -import Network.AWS.Data.ByteString -import Network.AWS.Data.Crypto -import Network.AWS.Data.Headers -import Network.AWS.Data.Sensitive (_Sensitive) -import Network.AWS.Data.Time -import Network.AWS.Lens ((<>~), (^.)) -import Network.AWS.Sign.V4.Base hiding (algorithm) -import Network.AWS.Types -import Network.HTTP.Types.Header - -import Numeric (showHex) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 - -default (Builder, Integer) - -chunked :: ChunkedBody -> Algorithm a -chunked c rq a r ts = signRequest meta (toRequestBody body) auth - where - (meta, auth) = base (Tag digest) (prepare rq) a r ts - - prepare = rqHeaders <>~ - [ (hContentEncoding, "aws-chunked") - , (hAMZDecodedContentLength, toBS (_chunkedLength c)) - , (hContentLength, toBS (metadataLength c)) - ] - - body = Chunked (c `fuseChunks` sign (metaSignature meta)) - - sign :: Monad m => Signature -> ConduitM ByteString ByteString m () - sign prev = do - mx <- await - let next = chunkSignature prev (fromMaybe mempty mx) - case mx of - Nothing -> yield (chunkData next mempty) - Just x -> yield (chunkData next x) >> sign next - - chunkData next x = toBS - $ word64Hex (fromIntegral (BS.length x)) - <> byteString chunkSignatureHeader - <> byteString (toBS next) - <> byteString crlf - <> byteString x - <> byteString crlf - - chunkSignature prev x = - signature (_authSecret a ^. _Sensitive) scope (chunkStringToSign prev x) - - chunkStringToSign prev x = Tag $ BS8.intercalate "\n" - [ algorithm - , time - , toBS scope - , toBS prev - , sha256Empty - , sha256 x - ] - - time :: ByteString - time = toBS (Time ts :: AWSTime) - - scope :: CredentialScope - scope = credentialScope (_rqService rq) end ts - - end :: Endpoint - end = _svcEndpoint (_rqService rq) r - -metadataLength :: ChunkedBody -> Integer -metadataLength c = - -- Number of full sized chunks. - fullChunks c * chunkLength (_chunkedSize c) - -- Non-full chunk preceeding the final chunk. - + maybe 0 chunkLength (remainderBytes c) - -- The final empty chunk. - + chunkLength 0 - where - chunkLength :: Integral a => a -> Integer - chunkLength (toInteger -> n) = - fromIntegral (length (showHex n "")) - + headerLength - + signatureLength - + crlfLength - + n - + crlfLength - - headerLength = toInteger (BS.length chunkSignatureHeader) - crlfLength = toInteger (BS.length crlf) - signatureLength = 64 - -sha256 :: ByteString -> ByteString -sha256 = digestToBase Base16 . hashSHA256 - -sha256Empty :: ByteString -sha256Empty = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" - -algorithm :: ByteString -algorithm = "AWS4-HMAC-SHA256-PAYLOAD" - -digest :: ByteString -digest = "STREAMING-AWS4-HMAC-SHA256-PAYLOAD" - -chunkSignatureHeader :: ByteString -chunkSignatureHeader = ";chunk-signature=" - -crlf :: ByteString -crlf = "\r\n" diff --git a/src/Network/AWS/Types.hs b/src/Network/AWS/Types.hs deleted file mode 100644 --- a/src/Network/AWS/Types.hs +++ /dev/null @@ -1,791 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} - --- | --- Module : Network.AWS.Types --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.AWS.Types - ( - -- * Authentication - -- ** Credentials - AccessKey (..) - , SecretKey (..) - , SessionToken (..) - -- ** Environment - , Auth (..) - , withAuth - - , AuthEnv (..) - , accessKeyId - , secretAccessKey - , sessionToken - , expiration - - -- * Logging - , LogLevel (..) - , Logger - - -- * Signing - , Algorithm - , Meta (..) - , Signer (..) - , Signed (..) - - -- * Service - , Abbrev - , Service (..) - , serviceSigner - , serviceEndpoint - , serviceTimeout - , serviceCheck - , serviceRetry - - -- * Requests - , AWSRequest (..) - , Request (..) - , rqService - , rqMethod - , rqHeaders - , rqPath - , rqQuery - , rqBody - , rqSign - , rqPresign - - -- * Responses - , Response - - -- * Retries - , Retry (..) - , exponentBase - , exponentGrowth - , retryAttempts - , retryCheck - - -- * Errors - , AsError (..) - , Error (..) - -- ** HTTP Errors - , HttpException - -- ** Serialize Errors - , SerializeError (..) - , serializeAbbrev - , serializeStatus - , serializeMessage - -- ** Service Errors - , ServiceError (..) - , serviceAbbrev - , serviceStatus - , serviceHeaders - , serviceCode - , serviceMessage - , serviceRequestId - -- ** Error Types - , ErrorCode (..) - , errorCode - , ErrorMessage (..) - , RequestId (..) - - -- * Regions - , Region (..) - - -- * Endpoints - , Endpoint (..) - , endpointHost - , endpointPort - , endpointSecure - , endpointScope - - -- * HTTP - , ClientRequest - , ClientResponse - , ResponseBody - , clientRequest - - -- ** Seconds - , Seconds (..) - , seconds - , microseconds - - -- * Isomorphisms - , _Coerce - , _Default - ) where - -import Control.Applicative -import Control.Concurrent (ThreadId) -import Control.DeepSeq -import Control.Exception -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource - -import Data.Aeson hiding (Error) -import Data.ByteString.Builder (Builder) -import Data.Coerce -import Data.Conduit -import Data.Data (Data, Typeable) -import Data.Hashable -import Data.IORef -import Data.Maybe -import Data.Monoid -import Data.Proxy -import Data.String -import Data.Time - -import GHC.Generics (Generic) - -import Network.AWS.Data.Body -import Network.AWS.Data.ByteString -import Network.AWS.Data.JSON -import Network.AWS.Data.Log -import Network.AWS.Data.Path -import Network.AWS.Data.Query -import Network.AWS.Data.Sensitive (Sensitive, _Sensitive) -import Network.AWS.Data.Text -import Network.AWS.Data.Time (ISO8601, _Time) -import Network.AWS.Data.XML -import Network.AWS.Lens (Iso', Lens', Prism', Setter') -import Network.AWS.Lens (exception, iso, lens, mapping, prism, sets, - view) -import Network.HTTP.Conduit hiding (Proxy, Request, Response) -import Network.HTTP.Types.Header -import Network.HTTP.Types.Method -import Network.HTTP.Types.Status (Status) - -import qualified Data.Text as Text -import qualified Network.HTTP.Conduit as Client - -#if ! MIN_VERSION_http_client(0,4,30) -import Text.XML (def) -#endif - --- | 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 = ConduitM () ByteString (ResourceT IO) () - --- | Abbreviated service name. -newtype Abbrev = Abbrev Text - deriving (Eq, Ord, Show, IsString, FromXML, FromJSON, FromText, ToText, ToLog) - -newtype ErrorCode = ErrorCode Text - deriving (Eq, Ord, Show, ToText, ToLog) - -instance IsString ErrorCode where fromString = errorCode . fromString -instance FromJSON ErrorCode where parseJSON = parseJSONText "ErrorCode" -instance FromXML ErrorCode where parseXML = parseXMLText "ErrorCode" - -instance FromText ErrorCode where - parser = errorCode <$> parser - --- | Construct an 'ErrorCode'. -errorCode :: Text -> ErrorCode -errorCode = ErrorCode . strip . unnamespace - where - -- Common suffixes are stripped since the service definitions are ambigiuous - -- as to whether the error shape's name, or the error code is present - -- in the response. - strip x = fromMaybe x $ - Text.stripSuffix "Exception" x <|> Text.stripSuffix "Fault" x - - -- Removing the (potential) leading ...# namespace. - unnamespace x = - case Text.break (== '#') x of - (ns, e) | Text.null e -> ns - | otherwise -> Text.drop 1 e - -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 Exception Error - -instance ToLog Error where - build = \case - TransportError e -> build e - SerializeError e -> build e - ServiceError e -> build e - -data SerializeError = SerializeError' - { _serializeAbbrev :: !Abbrev - , _serializeStatus :: !Status - , _serializeBody :: Maybe LazyByteString - -- ^ The response body, if the response was not streaming. - , _serializeMessage :: String - } deriving (Eq, Show, Typeable) - -instance ToLog SerializeError where - build SerializeError'{..} = buildLines - [ "[SerializeError] {" - , " service = " <> build _serializeAbbrev - , " status = " <> build _serializeStatus - , " message = " <> build _serializeMessage - , " body = " <> build _serializeBody - , "}" - ] - -serializeAbbrev :: Lens' SerializeError Abbrev -serializeAbbrev = lens _serializeAbbrev (\s a -> s { _serializeAbbrev = a }) - -serializeStatus :: Lens' SerializeError Status -serializeStatus = lens _serializeStatus (\s a -> s { _serializeStatus = a }) - -serializeMessage :: Lens' SerializeError String -serializeMessage = lens _serializeMessage (\s a -> s { _serializeMessage = 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 - , " message = " <> 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 - , _endpointSecure :: !Bool - , _endpointPort :: !Int - , _endpointScope :: ByteString - } deriving (Eq, Show, Data, Typeable) - -endpointHost :: Lens' Endpoint ByteString -endpointHost = lens _endpointHost (\s a -> s { _endpointHost = a }) - -endpointSecure :: Lens' Endpoint Bool -endpointSecure = lens _endpointSecure (\s a -> s { _endpointSecure = a }) - -endpointPort :: Lens' Endpoint Int -endpointPort = lens _endpointPort (\s a -> s { _endpointPort = a }) - -endpointScope :: Lens' Endpoint ByteString -endpointScope = lens _endpointScope (\s a -> s { _endpointScope = a }) - -data LogLevel - = Info -- ^ Info messages supplied by the user - this level is not emitted by the library. - | Error -- ^ Error messages only. - | Debug -- ^ Useful debug information + info + error levels. - | Trace -- ^ Includes potentially sensitive signing metadata, and non-streaming response bodies. - deriving (Eq, Ord, Enum, Show, Data, Typeable) - -instance FromText LogLevel where - parser = takeLowerText >>= \case - "info" -> pure Info - "error" -> pure Error - "debug" -> pure Debug - "trace" -> pure Trace - e -> fromTextError $ "Failure parsing LogLevel from " <> e - -instance ToText LogLevel where - toText = \case - Info -> "info" - Error -> "error" - Debug -> "debug" - Trace -> "trace" - -instance ToByteString LogLevel - --- | A function threaded through various request and serialisation routines --- to log informational and debug messages. -type Logger = LogLevel -> Builder -> IO () - --- | 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. - } - -exponentBase :: Lens' Retry Double -exponentBase = lens _retryBase (\s a -> s { _retryBase = a }) - -exponentGrowth :: Lens' Retry Int -exponentGrowth = lens _retryGrowth (\s a -> s { _retryGrowth = a }) - -retryAttempts :: Lens' Retry Int -retryAttempts = lens _retryAttempts (\s a -> s { _retryAttempts = a }) - -retryCheck :: Lens' Retry (ServiceError -> Maybe Text) -retryCheck = lens _retryCheck (\s a -> s { _retryCheck = a }) - --- | Signing algorithm specific metadata. -data Meta where - Meta :: ToLog a => a -> Meta - -instance ToLog Meta where - build (Meta m) = build m - --- | A signed 'ClientRequest' and associated metadata specific --- to the signing algorithm, tagged with the initial request type --- to be able to obtain the associated response, 'Rs a'. -data Signed a = Signed - { sgMeta :: !Meta - , sgRequest :: !ClientRequest - } - -type Algorithm a = Request a -> AuthEnv -> Region -> UTCTime -> Signed a - -data Signer = Signer - { sgSign :: forall a. Algorithm a - , sgPresign :: forall a. Seconds -> Algorithm a - } - --- | Attributes and functions specific to an AWS service. -data Service = Service - { _svcAbbrev :: !Abbrev - , _svcSigner :: !Signer - , _svcPrefix :: !ByteString - , _svcVersion :: !ByteString - , _svcEndpoint :: !(Region -> Endpoint) - , _svcTimeout :: !(Maybe Seconds) - , _svcCheck :: !(Status -> Bool) - , _svcError :: !(Status -> [Header] -> LazyByteString -> Error) - , _svcRetry :: !Retry - } - -serviceSigner :: Lens' Service Signer -serviceSigner = lens _svcSigner (\s a -> s { _svcSigner = a }) - -serviceEndpoint :: Setter' Service Endpoint -serviceEndpoint = sets (\f s -> s { _svcEndpoint = \r -> f (_svcEndpoint s r) }) - -serviceTimeout :: Lens' Service (Maybe Seconds) -serviceTimeout = lens _svcTimeout (\s a -> s { _svcTimeout = a }) - -serviceCheck :: Lens' Service (Status -> Bool) -serviceCheck = lens _svcCheck (\s a -> s { _svcCheck = a }) - -serviceRetry :: Lens' Service Retry -serviceRetry = lens _svcRetry (\s a -> s { _svcRetry = a }) - --- | Construct a 'ClientRequest' using common parameters such as TLS and prevent --- throwing errors when receiving erroneous status codes in respones. -clientRequest :: Endpoint -> Maybe Seconds -> ClientRequest -clientRequest e t = -#if MIN_VERSION_http_client(0,4,30) - Client.defaultRequest -#else - def -#endif - { Client.secure = _endpointSecure e - , Client.host = _endpointHost e - , Client.port = _endpointPort e - , Client.redirectCount = 0 - , Client.responseTimeout = -#if MIN_VERSION_http_client(0,5,0) - case t of - Nothing -> Client.responseTimeoutNone - Just x -> Client.responseTimeoutMicro (microseconds x) -#else - microseconds <$> t -#endif - } - --- | An unsigned request. -data Request a = Request - { _rqService :: !Service - , _rqMethod :: !StdMethod - , _rqPath :: !RawPath - , _rqQuery :: !QueryString - , _rqHeaders :: ![Header] - , _rqBody :: !RqBody - } - -rqService :: Lens' (Request a) Service -rqService = lens _rqService (\s a -> s { _rqService = a }) - -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 }) - -rqSign :: Algorithm a -rqSign x = sgSign (_svcSigner (_rqService x)) x - -rqPresign :: Seconds -> Algorithm a -rqPresign ex x = sgPresign (_svcSigner (_rqService x)) ex x - -type Response a = (Status, Rs a) - --- | Specify how a request can be de/serialised. -class AWSRequest a where - -- | The successful, expected response associated with a request. - type Rs a :: * - - request :: a -> Request a - response :: (MonadResource m, MonadThrow m) - => Logger - -> Service - -> Proxy a -- For injectivity reasons. - -> ClientResponse - -> m (Response a) - --- | An access key ID. --- --- For example: @AKIAIOSFODNN7EXAMPLE@ --- --- /See:/ . -newtype AccessKey = AccessKey ByteString - deriving - ( Eq - , Show - , Read - , Data - , Typeable - , IsString - , ToText - , FromText - , ToByteString - , ToLog - , FromXML - , ToXML - , ToQuery - , Hashable - , NFData - ) - -instance ToJSON AccessKey where toJSON = toJSONText -instance FromJSON AccessKey where parseJSON = parseJSONText "AccessKey" - --- | Secret access key credential. --- --- For example: @wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKE@ --- --- /See:/ . -newtype SecretKey = SecretKey ByteString - deriving - ( Eq - , Data - , Typeable - , IsString - , ToText - , FromText - , ToByteString - , FromXML - , ToXML - , Hashable - , NFData - ) - -instance ToJSON SecretKey where toJSON = toJSONText -instance FromJSON SecretKey where parseJSON = parseJSONText "SecretKey" - --- | A session token used by STS to temporarily authorise access to --- an AWS resource. --- --- /See:/ . -newtype SessionToken = SessionToken ByteString - deriving - ( Eq - , Data - , Typeable - , IsString - , ToText - , FromText - , ToByteString - , FromXML - , ToXML - , Hashable - , NFData - ) - -instance ToJSON SessionToken where toJSON = toJSONText -instance FromJSON SessionToken where parseJSON = parseJSONText "SessionToken" - --- | The AuthN/AuthZ credential environment. -data AuthEnv = AuthEnv - { _authAccess :: !AccessKey - , _authSecret :: !(Sensitive SecretKey) - , _authToken :: Maybe (Sensitive SessionToken) - , _authExpiry :: Maybe ISO8601 - } deriving (Eq, Show, Data, Typeable, Generic) - -instance NFData AuthEnv - -instance ToLog AuthEnv where - build AuthEnv{..} = buildLines - [ "[Amazonka Auth] {" - , " access key id = " <> build _authAccess - , " secret access key = " <> build _authSecret - , " session token = " <> build _authToken - , " expiration = " <> build (fmap (view _Time) _authExpiry) - , "}" - ] - -instance FromJSON AuthEnv where - parseJSON = withObject "AuthEnv" $ \o -> AuthEnv - <$> o .: "AccessKeyId" - <*> o .: "SecretAccessKey" - <*> o .:? "Token" - <*> o .:? "Expiration" - -instance FromXML AuthEnv where - parseXML x = AuthEnv - <$> x .@ "AccessKeyId" - <*> x .@ "SecretAccessKey" - <*> x .@? "SessionToken" - <*> x .@? "Expiration" - --- | The access key ID that identifies the temporary security credentials. -accessKeyId :: Lens' AuthEnv AccessKey -accessKeyId = lens _authAccess (\s a -> s{ _authAccess = a }) - --- | The secret access key that can be used to sign requests. -secretAccessKey :: Lens' AuthEnv SecretKey -secretAccessKey = - lens _authSecret (\s a -> s { _authSecret = a }) - . _Sensitive - --- | The token that users must pass to the service API to use the temporary --- credentials. -sessionToken :: Lens' AuthEnv (Maybe SessionToken) -sessionToken = - lens _authToken (\s a -> s { _authToken = a }) - . mapping _Sensitive - --- | The date on which the current credentials expire. -expiration :: Lens' AuthEnv (Maybe UTCTime) -expiration = - lens _authExpiry (\s a -> s { _authExpiry = a }) - . mapping _Time - --- | An authorisation environment containing AWS credentials, and potentially --- a reference which can be refreshed out-of-band as temporary credentials expire. -data Auth - = Ref ThreadId (IORef AuthEnv) - | Auth AuthEnv - -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 (Ref _ r) f = liftIO (readIORef r) >>= f -withAuth (Auth e) f = f e - --- | The available AWS regions. -data Region - = NorthVirginia -- ^ US East ('us-east-1'). - | Ohio -- ^ US East ('us-east-2'). - | NorthCalifornia -- ^ US West ('us-west-1'). - | Oregon -- ^ US West ('us-west-2'). - | Montreal -- ^ Canada ('ca-central-1'). - | Tokyo -- ^ Asia Pacific ('ap-northeast-1'). - | Seoul -- ^ Asia Pacific ('ap-northeast-2'). - | Mumbai -- ^ Asia Pacific ('ap-south-1'). - | Singapore -- ^ Asia Pacific ('ap-southeast-1'). - | Sydney -- ^ Asia Pacific ('ap-southeast-2'). - | SaoPaulo -- ^ South America ('sa-east-1'). - | Ireland -- ^ EU ('eu-west-1'). - | London -- ^ EU ('eu-west-2'). - | Frankfurt -- ^ EU ('eu-central-1'). - | GovCloud -- ^ US GovCloud ('us-gov-west-1'). - | GovCloudFIPS -- ^ US GovCloud FIPS (S3 Only, 'fips-us-gov-west-1'). - | Beijing -- ^ China ('cn-north-1'). - deriving (Eq, Ord, Read, Enum, Bounded, Show, Data, Typeable, Generic) - -instance Hashable Region -instance NFData Region - -instance FromText Region where - parser = takeLowerText >>= \case - "us-east-1" -> pure NorthVirginia - "us-east-2" -> pure Ohio - "us-west-1" -> pure NorthCalifornia - "us-west-2" -> pure Oregon - "ca-central-1" -> pure Montreal - "ap-northeast-1" -> pure Tokyo - "ap-northeast-2" -> pure Seoul - "ap-south-1" -> pure Mumbai - "ap-southeast-1" -> pure Singapore - "ap-southeast-2" -> pure Sydney - "sa-east-1" -> pure SaoPaulo - "eu-west-1" -> pure Ireland - "eu-west-2" -> pure London - "eu-central-1" -> pure Frankfurt - "us-gov-west-1" -> pure GovCloud - "fips-us-gov-west-1" -> pure GovCloudFIPS - "cn-north-1" -> pure Beijing - e -> - fromTextError $ "Failure parsing Region from " <> e - -instance ToText Region where - toText = \case - NorthVirginia -> "us-east-1" - Ohio -> "us-east-2" - NorthCalifornia -> "us-west-1" - Oregon -> "us-west-2" - Montreal -> "ca-central-1" - Tokyo -> "ap-northeast-1" - Seoul -> "ap-northeast-2" - Mumbai -> "ap-south-1" - Singapore -> "ap-southeast-1" - Sydney -> "ap-southeast-2" - SaoPaulo -> "sa-east-1" - Ireland -> "eu-west-1" - London -> "eu-west-2" - Frankfurt -> "eu-central-1" - GovCloud -> "us-gov-west-1" - GovCloudFIPS -> "fips-us-gov-west-1" - Beijing -> "cn-north-1" - -instance ToByteString Region - -instance ToLog Region where - build = build . toBS - -instance FromXML Region where parseXML = parseXMLText "Region" -instance ToXML Region where toXML = toXMLText -instance FromJSON Region where parseJSON = parseJSONText "Region" -instance ToJSON Region where toJSON = toJSONText - --- | 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 - , FromText - ) - -instance Hashable Seconds -instance NFData Seconds - -instance ToLog Seconds where - build s = build (seconds s) <> "s" - -seconds :: Seconds -> Int -seconds (Seconds n) - | n < 0 = 0 - | otherwise = n - -microseconds :: Seconds -> Int -microseconds = (1000000 *) . seconds - -_Coerce :: (Coercible a b, Coercible b a) => Iso' a b -_Coerce = iso coerce coerce - --- | 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 deleted file mode 100644 --- a/src/Network/AWS/Waiter.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Module : Network.AWS.Waiter --- Copyright : (c) 2013-2018 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 - , matchNonEmpty - , matchError - , matchStatus - - -- * Util - , nonEmptyText - ) where - -import Control.Lens (Fold, allOf, anyOf, to, (^..), - (^?)) -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import Network.AWS.Data.ByteString -import Network.AWS.Data.Log -import Network.AWS.Error -import Network.AWS.Types - -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 - -matchNonEmpty :: Bool -> Accept -> Fold (Rs a) b -> Acceptor a -matchNonEmpty x a l = match (\rs -> null (rs ^.. l) == x) a - -matchStatus :: Int -> Accept -> Acceptor a -matchStatus x a _ = \case - Right (s, _) | x == fromEnum s -> Just a - 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 - -nonEmptyText :: Fold a Text -> Fold a Bool -nonEmptyText f = f . to Text.null diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,51 +1,50 @@ -{-# LANGUAGE TemplateHaskell #-} - -- | -- Module : Main --- Copyright : (c) 2013-2018 Brendan Hay +-- Copyright : (c) 2013-2023 Brendan Hay -- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay --- Stability : experimental +-- Stability : provisional -- Portability : non-portable (GHC extensions) --- module Main (main) where -import qualified Test.AWS.Data.Base64 as Base64 -import qualified Test.AWS.Data.List as List -import qualified Test.AWS.Data.Maybe as Maybe -import qualified Test.AWS.Data.Numeric as Numeric -import qualified Test.AWS.Data.Path as Path -import qualified Test.AWS.Data.Query as Query -import qualified Test.AWS.Data.Time as Time -import qualified Test.AWS.Error as Error -import qualified Test.AWS.Sign.V2Header.BaseSpec as V2Header -import qualified Test.AWS.Sign.V4 as V4 - -import Test.Tasty +import qualified Test.Amazonka.Data.Base64 as Base64 +import qualified Test.Amazonka.Data.List as List +import qualified Test.Amazonka.Data.Maybe as Maybe +import qualified Test.Amazonka.Data.Numeric as Numeric +import qualified Test.Amazonka.Data.Path as Path +import qualified Test.Amazonka.Data.Query as Query +import qualified Test.Amazonka.Data.Time as Time +import qualified Test.Amazonka.Error as Error +import qualified Test.Amazonka.Sign.V2Header as V2Header +import qualified Test.Amazonka.Sign.V4 as V4 +import Test.Tasty +import Prelude main :: IO () -main = defaultMain $ - testGroup "amazonka-core" - [ testGroup "primitives" - [ Numeric.tests - , Time.tests - , Base64.tests - , Maybe.tests - , Query.tests - ] - - , testGroup "paths" - [ Path.tests - ] - - , testGroup "collections" - [ List.tests - ] - - , testGroup "signing" - [ V2Header.tests - , V4.tests - ] - - , Error.tests - ] +main = + defaultMain $ + testGroup + "amazonka-core" + [ testGroup + "primitives" + [ Numeric.tests, + Time.tests, + Base64.tests, + Maybe.tests, + Query.tests + ], + testGroup + "paths" + [ Path.tests + ], + testGroup + "collections" + [ List.tests + ], + testGroup + "signing" + [ V2Header.tests, + V4.tests + ], + Error.tests + ] diff --git a/test/Test/AWS/Arbitrary.hs b/test/Test/AWS/Arbitrary.hs deleted file mode 100644 --- a/test/Test/AWS/Arbitrary.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Module : Test.AWS.Arbitrary --- Copyright : (c) 2013-2018 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 qualified Data.Text.Encoding as Text -import Data.Time -import Network.AWS.Data.Query -import Network.AWS.Prelude -import Network.AWS.Sign.V4 -import Network.HTTP.Types -import Test.QuickCheck.Gen as QC -import qualified Test.QuickCheck.Unicode as Unicode -import Test.Tasty.QuickCheck - -instance Show (Signed a) where - show = const "Signed { }" - -instance Arbitrary Service where - arbitrary = svc <$> arbitrary - where - svc abbrev = Service - { _svcAbbrev = abbrev - , _svcSigner = v4 - , _svcPrefix = Text.encodeUtf8 . Text.toLower $ toText abbrev - , _svcVersion = "2012-01-01" - , _svcEndpoint = defaultEndpoint (svc abbrev) - , _svcTimeout = Nothing - , _svcCheck = const False - , _svcRetry = Exponential 1 2 3 (Just . Text.pack . show) - , _svcError = \status hdrs _ -> - ServiceError $ ServiceError' - { _serviceAbbrev = abbrev - , _serviceStatus = status - , _serviceHeaders = hdrs - , _serviceCode = ErrorCode "Arbitrary.Service" - , _serviceMessage = Nothing - , _serviceRequestId = Nothing - } - } - -instance Arbitrary (Request ()) where - arbitrary = Request - <$> arbitrary - <*> 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 = sized arbitraryQS - --- | Used to limit the recursion depth. -arbitraryQS :: Int -> Gen QueryString -arbitraryQS = \case - 0 -> QPair <$> arbitrary <*> (QValue <$> arbitrary) - n -> oneof - [ QValue <$> arbitrary - , QPair <$> arbitrary <*> arbitraryQS (n - 1) - , QList <$> (take 4 <$> QC.listOf (arbitraryQS (n `div` 2))) - ] - -instance (Arbitrary a, FoldCase a) => Arbitrary (CI a) where - 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 - -instance Arbitrary (Time a) where - arbitrary = Time <$> arbitrary - -instance Arbitrary AccessKey where - arbitrary = AccessKey <$> arbitrary - -instance (Arbitrary a) => Arbitrary (Sensitive a) where - arbitrary = Sensitive <$> arbitrary - -instance Arbitrary SecretKey where - arbitrary = SecretKey . fromString <$> suchThat Unicode.string (not . null) - -instance Arbitrary SessionToken where - arbitrary = SessionToken <$> arbitrary - -instance Arbitrary AuthEnv where - arbitrary = AuthEnv <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary diff --git a/test/Test/AWS/Data/Base64.hs b/test/Test/AWS/Data/Base64.hs deleted file mode 100644 --- a/test/Test/AWS/Data/Base64.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Test.AWS.Data.Base64 --- Copyright : (c) 2013-2018 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 deleted file mode 100644 --- a/test/Test/AWS/Data/List.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Test.AWS.Data.List --- Copyright : (c) 2013-2018 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.Util -import Test.Tasty - -tests :: TestTree -tests = testGroup "list" - [ 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])) - ] - ] - ] - - , testGroup "xml" - [ testGroup "deserialise" - [ testGroup "non-flattened" - [ testFromXML "absent" - "absent" - (NonFlat "absent" absent) - - , testFromXML "empty" - "empty" - (NonFlat "empty" absent) - - , 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])) - ] - ] - ] - ] - -empty :: Maybe [Int] -empty = Just [] - -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/Maybe.hs b/test/Test/AWS/Data/Maybe.hs deleted file mode 100644 --- a/test/Test/AWS/Data/Maybe.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Test.AWS.Data.Maybe --- Copyright : (c) 2013-2018 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 deleted file mode 100644 --- a/test/Test/AWS/Data/Numeric.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- Module : Test.AWS.Data.Numeric --- Copyright : (c) 2013-2018 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 Control.Applicative -import Network.AWS.Prelude -import Test.AWS.Util -import Test.Tasty - -tests :: TestTree -tests = testGroup "numeric" - [ testGroup "json" - [ testGroup "deserialisation" - [ testFromJSON "natural" - "123" (Nat 123) - - , testFromJSON "int" - (toLazyBS maxInt) maxInt - - , 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) - ] - ] - - , testGroup "xml" - [ testGroup "deserialisation" - [ testFromXML "natural" - "123" (Nat 123) - - , testFromXML "int" - (toLazyBS maxInt) maxInt - - , testFromXML "negative int" - (toLazyBS minInt) minInt - - , testFromXML "integer" - "891324" (891324 :: Integer) - - , testFromXML "negative integer" - "-998" (-998 :: Integer) - - , testFromXML "double" - "46.39212" (46.39212 :: Double) - - , testFromXML "negative double" - "-1.09231" (-1.09231 :: Double) - - , testFromXML "numeric string" - "22" ("22" :: Text) - ] - - , testGroup "serialisation" - [ testToXML "natural" - "123" (Nat 123) - - , testToXML "int" - (toLazyBS maxInt) maxInt - - , testToXML "negative int" - (toLazyBS minInt) minInt - - , testToXML "integer" - "891324" (891324 :: Integer) - - , 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/Path.hs b/test/Test/AWS/Data/Path.hs deleted file mode 100644 --- a/test/Test/AWS/Data/Path.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Test.AWS.Data.Path --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Data.Path (tests) where - -import Network.AWS.Prelude -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "path" - [ testGroup "encode" - [ testCase "doesn't append trailing slash" $ - let x = "/path/without/trailing/slash" in encode x @?= x - - , testCase "preserves trailing slash" $ - let x = "/some/path/with/trailing/slash/" in encode x @?= x - - , testCase "preserves adjacent slashes" $ - let x = "/path//with/adjacent///slahes/" in encode x @?= x - ] - ] - -encode :: ByteString -> ByteString -encode = toBS . escapePath . rawPath diff --git a/test/Test/AWS/Data/Query.hs b/test/Test/AWS/Data/Query.hs deleted file mode 100644 --- a/test/Test/AWS/Data/Query.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Test.AWS.Query.List --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Data.Query (tests) where - -import Network.AWS.Prelude -import Test.Tasty -import Test.Tasty.HUnit (testCase, (@?=)) - -tests :: TestTree -tests = testGroup "query" - [ testGroup "fromString" - [ testCase "key" $ - parseQueryString "foo" @?= - QList [ QPair "foo" (QValue Nothing) - ] - - , testCase "key=" $ - parseQueryString "foo=" @?= - QList [ QPair "foo" (QValue Nothing) - ] - - , testCase "key=value" $ - parseQueryString "foo=bar" @?= - QList [ QPair "foo" (QValue (Just "bar")) - ] - - , testCase "key&.." $ - parseQueryString "foo&bar&baz" @?= - QList [ QPair "foo" (QValue Nothing) - , QPair "bar" (QValue Nothing) - , QPair "baz" (QValue Nothing) - ] - - , testCase "key=value&.." $ - parseQueryString "foo=1&bar=2&baz&qux=3" @?= - QList [ QPair "foo" (QValue (Just "1")) - , QPair "bar" (QValue (Just "2")) - , QPair "baz" (QValue Nothing) - , QPair "qux" (QValue (Just "3")) - ] - - ] - ] diff --git a/test/Test/AWS/Data/Time.hs b/test/Test/AWS/Data/Time.hs deleted file mode 100644 --- a/test/Test/AWS/Data/Time.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- Module : Test.AWS.Data.Time --- Copyright : (c) 2013-2018 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 Network.AWS.Compat.Locale -import Network.AWS.Compat.Time -import Network.AWS.Prelude -import Test.AWS.Util -import Test.Tasty - -tests :: TestTree -tests = testGroup "time" - [ 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 "serialise" - [ testToText "rfc822" - "Fri, 07 Nov 2014 04:42:13 GMT" (time :: RFC822) - - , testToText "iso8601" - "2014-11-07T04:42:13Z" (time :: ISO8601) - - , testToText "aws" - "20141107T044213Z" (time :: AWSTime) - ] - ] - - , 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%3A13Z" (time :: ISO8601) - - , testToQuery "aws" - "x=20141107T044213Z" (time :: AWSTime) - ] - ] - - , 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 "serialise" - [ testToXML "rfc822" - "Fri, 07 Nov 2014 04:42:13 GMT" (time :: RFC822) - - , testToXML "iso8601" - "2014-11-07T04:42:13Z" (time :: ISO8601) - - , testToXML "aws" - "20141107T044213Z" (time :: AWSTime) - ] - ] - - , testGroup "json" - [ testGroup "deserialise" - [ testFromJSON "rfc822" - (str "Fri, 07 Nov 2014 04:42:13 GMT") (time :: RFC822) - - , testFromJSON "iso8601" - (str "2014-11-07T04:42:13.000Z") (time :: ISO8601) - - , testFromJSON "aws" - (str "20141107T044213Z") (time :: AWSTime) - - , 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:13Z") (time :: ISO8601) - - , testToJSON "aws" - (str "20141107T044213Z") (time :: AWSTime) - - , testToJSON "posix" - "1415335333" (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/Error.hs b/test/Test/AWS/Error.hs deleted file mode 100644 --- a/test/Test/AWS/Error.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Test.AWS.Error --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Error (tests) where - -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Foldable as Fold -import Data.List (sort) -import Data.Monoid -import Data.String -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Network.AWS.Error -import Network.AWS.Prelude -import Test.AWS.Arbitrary () -import Test.QuickCheck.Property () -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "errors" - [ testGroup "xml" - [ testCase "ec2" $ xmlError ec2 - "VolumeInUse" - "vol-8c8cea98 is already attached to an instance" - "c0ca7700-c515-4653-87e3-f1a9ce6416e8" - - , testCase "route53" $ xmlError route53 - "InvalidChangeBatch" - "Tried to delete resource record set noexist.example.com. type A,but it was not found" - "default_rid" - - , testCase "sqs" $ xmlError sqs - "InvalidParameterValue" - "Value (quename_nonalpha) for parameter QueueName is invalid. Must be an alphanumeric String of 1 to 80 in length" - "42d59b56-7407-4c4a-be0f-4c88daeea257" - ] - ] - -xmlError :: LazyByteString - -> ErrorCode - -> ErrorMessage - -> RequestId - -> Assertion -xmlError bs c m r = actual @?= Right expect - where - expect = serviceError a s h (Just c) (Just m) (Just r) - actual = - case parseXMLError a s h bs of - ServiceError e -> Right e - e -> Left $ "unexpected error: " ++ show e - - a = "Test" - s = toEnum 400 - h = [(hAMZRequestId, "default_rid")] - --- Samples representative of differing xml errors. - -ec2 :: LazyByteString -ec2 = "VolumeInUsevol-8c8cea98 is already attached to an instancec0ca7700-c515-4653-87e3-f1a9ce6416e8" - -route53 :: LazyByteString -route53 = "Tried to delete resource record set noexist.example.com. type A,but it was not found" - -sqs :: LazyByteString -sqs = "SenderInvalidParameterValueValue (quename_nonalpha) for parameter QueueName is invalid. Must be an alphanumeric String of 1 to 80 in length42d59b56-7407-4c4a-be0f-4c88daeea257" diff --git a/test/Test/AWS/Sign/V2Header/BaseSpec.hs b/test/Test/AWS/Sign/V2Header/BaseSpec.hs deleted file mode 100644 --- a/test/Test/AWS/Sign/V2Header/BaseSpec.hs +++ /dev/null @@ -1,278 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Test.AWS.Sign.V2Header.BaseSpec --- Stability : experimental --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Sign.V2Header.BaseSpec (tests) where - -import Control.Applicative -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.CaseInsensitive as CI -import qualified Data.List as List -import Data.List.Ordered (subset) -import Data.Maybe (isJust) -import Data.Monoid ((<>)) -import qualified Data.Text as Text -import qualified Network.AWS.Data.Query as Query -import Network.AWS.Sign.V2Header.Base -import qualified Network.HTTP.Types as HTTP -import qualified Test.QuickCheck as QC -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) -import Test.Tasty.QuickCheck (Gen, Property, testProperty) - -tests :: TestTree -tests = testGroup "v2Header.BaseSpec" - [ testGroup "constructSigningQuery" - - [ testProperty "should always convert set QValues to Nothing" - prop_QValueEmpty - , testCase "should keep an unset QValue" $ - constructSigningQuery (Query.QValue (Nothing :: Maybe ByteString)) @?= (Query.QValue (Nothing :: Maybe ByteString)) - , testProperty "should discard QPairs that are not interesting to AWS" - prop_UninterestingQPairs - , testProperty "should keep all QPairs that are interesting to AWS" - prop_InterestingQPairs - , testCase "should keep an empty QList" $ - constructSigningQuery (Query.QList []) @?= Query.QList [] - , testCase "should keep a list of Nothing QValues" $ - constructSigningQuery (Query.QList [(Query.QValue Nothing)]) @?= (Query.QList [(Query.QValue Nothing)]) - , testProperty "should discard the contents of an unintersting QList" - prop_UninterestingQLists - , testProperty "should not discard all QC.elements in interesting QLists" - prop_InterestingQLists - ] - - , testGroup "constructSigningHeader" - [ testProperty "should convert random headers to their header value" - prop_RandomHeaders - , testProperty "should convert interesting headers to their header value" - prop_InterestingHeaders - , testProperty "should convert aws headers to a canonical string" - prop_InterestingAwsHeaders - ] - - , testGroup "auxiliary headers functions" - [ testProperty "should sort and preserve headers" - prop_SortedHeaders - , testCase "should contain empty md5 and empty content type headers if not present" $ - [(HTTP.hContentMD5, ""), (HTTP.hContentType, "")] `subset` (unionNecessaryHeaders []) @?= True - , testCase "should preserve a set md5 and contain an empty content type header if not present" $ - [(HTTP.hContentMD5, "123"), (HTTP.hContentType, "")] `subset` (unionNecessaryHeaders [(HTTP.hContentMD5, "123")]) @?= True - , testCase "should preserve a set content type and preserve an empty md5 header if not present" $ - [(HTTP.hContentType, "123"), (HTTP.hContentMD5, "")] `subset` (unionNecessaryHeaders [(HTTP.hContentType, "123")]) @?= True - , testCase "should preserve md5 and content type headers if set" $ - [(HTTP.hContentType, "123"), (HTTP.hContentMD5, "456")] `subset` unionNecessaryHeaders [(HTTP.hContentType, "123"), (HTTP.hContentMD5, "456")] @?= True - ] - - , testGroup "toSingerQBS" - [ testCase "should convert an empty query string" $ - toSignerQueryBS (Query.QValue Nothing) @?= "" - , testCase "should convert an empty value of QPair to just the key" $ - toSignerQueryBS (Query.QPair "key" (Query.QValue Nothing)) @?= "key" - , testCase "should convert an empty value of QPair followed by QValue to just the key and just the value" $ - toSignerQueryBS (Query.QList [(Query.QPair "key" (Query.QValue Nothing)), (Query.QValue $ - Just "key2")]) @?= "key&key2" - ] - - , testGroup "constructFullPath" - [ testCase "should convert an empty queryString to just the path" $ - constructFullPath "path" "" @?= "path" - , testCase "should convert an empty value of QPair and a path to just the path and the key" $ - constructFullPath "path" (toSignerQueryBS (Query.QPair "key" (Query.QValue Nothing))) @?= "path?key" - ] - - , testGroup "should construct canonical headers" - [ testCase "should construct a canonical header from a base string" $ - newSigner [] "GET" "\\" "" @?= "GET\n\n\n\\" - ] - - ] - --- Properties for non-empty QValues - -prop_QValueEmpty :: Property -prop_QValueEmpty = - QC.forAll uninterestingQValues $ \qv -> - constructSigningQuery qv == - Query.QValue (Nothing :: Maybe ByteString) - --- Generators / properties for uninteresting query pairs - -prop_UninterestingQPairs :: Property -prop_UninterestingQPairs = - QC.forAll uninterestingQPairs $ \qpair -> - constructSigningQuery qpair == Query.QValue Nothing - -uninterestingQPairs :: Gen Query.QueryString -uninterestingQPairs = - Query.toQuery <$> ((,) <$> nonEmptyText <*> uninterestingQValues) - --- Generators / properties for interesting query pairs - -prop_InterestingQPairs :: Property -prop_InterestingQPairs = - QC.forAll interestingQPairs $ \qpair -> - constructSigningQuery qpair /= Query.QValue Nothing - -interestingQueryKey :: Gen ByteString -interestingQueryKey = - QC.elements - [ "acl" - , "cors" - , "defaultObjectAcl" - , "location" - , "logging" - , "partNumber" - , "policy" - , "requestPayment" - , "torrent" - , "versioning" - , "versionId" - , "versions" - , "website" - , "uploads" - , "uploadId" - , "response-content-type" - , "response-content-language" - , "response-expires" - , "response-cache-control" - , "response-content-disposition" - , "response-content-encoding" - , "delete" - , "lifecycle" - , "tagging" - , "restore" - , "storageClass" - , "websiteConfig" - , "compose" - ] - -interestingQPairs :: Gen Query.QueryString -interestingQPairs = - Query.toQuery <$> ((,) <$> interestingQueryKey <*> uninterestingQValues) - --- Generators / properties for query lists - -prop_UninterestingQLists :: Property -prop_UninterestingQLists = - QC.forAll uninterestingQLists $ - not . containsAnything . constructSigningQuery - -uninterestingQLists :: Gen Query.QueryString -uninterestingQLists = - Query.toQueryList - <$> nonEmptyByteString - <*> QC.listOf - ( QC.frequency - [ (1, uninterestingQPairs) - , (1, uninterestingQValues) - , (1, uninterestingQLists) - ] - ) - -containsAnything :: Query.QueryString -> Bool -containsAnything = \case - Query.QValue v -> isJust v - Query.QPair {} -> True - Query.QList qs -> any containsAnything qs - -interestingQLists :: Gen Query.QueryString -interestingQLists = - Query.toQueryList - <$> interestingQueryKey - <*> QC.listOf - ( QC.frequency - [ (1, interestingQLists) - , (1, uninterestingQPairs) - , (1, uninterestingQValues) - , (1, uninterestingQLists) - ] - ) - --- this property should probably be expanded to check that all qpairs actually contain interesting query keys AND that uninteresting --- query keys are actually preserved underneath an interesting one -prop_InterestingQLists :: Property -prop_InterestingQLists = - QC.forAll interestingQLists $ - containsAnything . constructSigningQuery - -prop_RandomHeaders :: Property -prop_RandomHeaders = - QC.forAll randomHeaderGenerator $ \hdr -> - constructSigningHeader hdr == snd hdr - -prop_InterestingHeaders :: Property -prop_InterestingHeaders = - QC.forAll interestingHeaderGenerator $ \hdr -> - constructSigningHeader hdr == snd hdr - -prop_InterestingAwsHeaders :: Property -prop_InterestingAwsHeaders = - QC.forAll interestingAwsHeaderGenerator $ \hdr -> - constructSigningHeader hdr == - (CI.foldedCase (fst hdr) <> ":" <> snd hdr) - --- Generator / Property for headers -randomHeaderGenerator :: Gen HTTP.Header -randomHeaderGenerator = - (,) <$> (CI.mk <$> nonEmptyByteString) <*> nonEmptyByteString - -interestingAwsHeaderName :: Gen HTTP.HeaderName -interestingAwsHeaderName = - CI.mk <$> BS8.pack <$> fmap ("aws-" <>) nonEmptyString - -interestingHeaderName :: Gen HTTP.HeaderName -interestingHeaderName = - QC.elements [HTTP.hContentMD5, HTTP.hContentType, HTTP.hDate] - -interestingHeaderGenerator :: Gen HTTP.Header -interestingHeaderGenerator = - (,) <$> interestingHeaderName <*> nonEmptyByteString - -interestingAwsHeaderGenerator :: Gen HTTP.Header -interestingAwsHeaderGenerator = - (,) <$> interestingAwsHeaderName <*> nonEmptyByteString - --- Generators / Properties for auxiliary header functions - -prop_SortedHeaders :: Property -prop_SortedHeaders = - QC.forAll allHeadersGenerator $ \allHeaders -> testHeaders allHeaders - -allHeadersGenerator :: Gen [HTTP.Header] -allHeadersGenerator = - QC.listOf $ QC.frequency - [ (1, interestingHeaderGenerator) - , (1, interestingAwsHeaderGenerator) - ] - -allIncreasing :: [HTTP.Header] -> Bool -allIncreasing xs = - and $ zipWith (<=) mapped $ drop 1 mapped - where - mapped = map fst xs - -testHeaders :: [HTTP.Header] -> Bool -testHeaders headers = - length sortedHeaders == length sortedHeaders && allIncreasing sortedHeaders - where - sortedHeaders = List.sort headers - --- Generators for Text / QueryValues - -nonEmptyByteString :: Gen ByteString -nonEmptyByteString = BS8.pack <$> nonEmptyString - -uninterestingQValues :: Gen Query.QueryString -uninterestingQValues = Query.toQuery <$> nonEmptyText - -nonEmptyText :: Gen Text.Text -nonEmptyText = Text.pack <$> nonEmptyString - -nonEmptyString :: Gen String -nonEmptyString = QC.listOf1 QC.arbitrary diff --git a/test/Test/AWS/Sign/V4.hs b/test/Test/AWS/Sign/V4.hs deleted file mode 100644 --- a/test/Test/AWS/Sign/V4.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Test.AWS.Sign.V$ --- Copyright : (c) 2013-2018 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 Test.Tasty (TestTree, testGroup) - -import qualified Test.AWS.Sign.V4.Chunked as Chunked - --- 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 "chunked" - [ Chunked.tests - ] - ] diff --git a/test/Test/AWS/Sign/V4/Chunked.hs b/test/Test/AWS/Sign/V4/Chunked.hs deleted file mode 100644 --- a/test/Test/AWS/Sign/V4/Chunked.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Test.AWS.Sign.V$ --- Copyright : (c) 2013-2018 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : experimental --- Portability : non-portable (GHC extensions) --- -module Test.AWS.Sign.V4.Chunked (tests) where - -import Prelude hiding (elem) - -import Data.List (sort) -import Data.Monoid -import Data.String - -import Network.AWS.Lens ((%~), (&), (.~)) -import Network.AWS.Prelude -import Network.AWS.Sign.V4 - -import Numeric (showHex) - -import Test.AWS.Arbitrary () -import Test.QuickCheck.Property () -import Test.Tasty -import Test.Tasty.QuickCheck - -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Conduit.List as Conduit -import qualified Data.Foldable as Fold -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Network.HTTP.Conduit as Client -import qualified Test.QuickCheck as QC - -tests :: TestTree -tests = testGroup "headers" - [ testProperty "empty body" testEmptyBody - , testProperty "1 chunk body" testOneChunkBody - , testProperty "2 chunks body" testTwoChunksBody - ] - -testEmptyBody :: Property -testEmptyBody = - QC.forAll (mkSigned []) $ \Signed{..} -> - let elem = (`Fold.elem` Client.requestHeaders sgRequest) - in elem ("Content-Encoding", "aws-chunked") - && elem ("X-Amz-Decoded-Content-Length", "0") - && elem ("Content-Length", "86") - -testOneChunkBody :: Property -testOneChunkBody = - let n = 123 - str = BS8.pack . show - inp = BS8.replicate n 'a' - - in QC.forAll (mkSigned [inp]) $ \Signed{..} -> - let elem = (`Fold.elem` Client.requestHeaders sgRequest) - in elem ("Content-Encoding", "aws-chunked") - && elem ("X-Amz-Decoded-Content-Length", str n) - && elem ("Content-Length", str (87 + n + 86)) - -testTwoChunksBody :: Property -testTwoChunksBody = - let size = fromIntegral defaultChunkSize - sizeLen = length (showHex size "") - n = 123 - str = BS8.pack . show - full = BS8.replicate size 'a' -- full-sized chunk - final = BS8.replicate n 'b' -- final non-empty chunk - - in QC.forAll (mkSigned [full, final]) $ \Signed{..} -> - let elem = (`Fold.elem` Client.requestHeaders sgRequest) - in elem ("Content-Encoding", "aws-chunked") - && elem ("X-Amz-Decoded-Content-Length", str (size + n)) - && elem ("Content-Length", str (sizeLen + 85 + size + 87 + n + 86)) - -mkSigned :: [BS8.ByteString] -> Gen (Signed ()) -mkSigned bs = do - aReq <- arbitrary - aService <- arbitrary - - let svc = aService - & serviceSigner .~ v4 - - req = aReq - & rqBody .~ Chunked (mkBody bs) - & rqService .~ svc - - rqSign req <$> arbitrary <*> arbitrary <*> arbitrary - -mkBody :: [BS8.ByteString] -> ChunkedBody -mkBody bs = - ChunkedBody defaultChunkSize - (fromIntegral . sum $ fmap BS8.length bs) - (Conduit.sourceList bs) - diff --git a/test/Test/AWS/Util.hs b/test/Test/AWS/Util.hs deleted file mode 100644 --- a/test/Test/AWS/Util.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Test.AWS.Util --- Copyright : (c) 2013-2018 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 diff --git a/test/Test/Amazonka/Arbitrary.hs b/test/Test/Amazonka/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Arbitrary.hs @@ -0,0 +1,182 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Test.Amazonka.Arbitrary +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Arbitrary where + +import Amazonka.Core +import Amazonka.Data +import Amazonka.Prelude +import Amazonka.Sign.V4 +import qualified Data.ByteString.Char8 as BS8 +import Data.CaseInsensitive (FoldCase) +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Time (Day (..), UTCTime (..)) +import Network.HTTP.Types (StdMethod (..)) +import Test.QuickCheck.Gen as QC +import qualified Test.QuickCheck.Unicode as Unicode +import Test.Tasty.QuickCheck + +instance Show (Signed a) where + show = const "Signed { }" + +instance Arbitrary Service where + arbitrary = svc <$> arbitrary + where + svc abbrev = + Service + { abbrev = abbrev, + signer = v4, + signingName = Text.encodeUtf8 . Text.toLower $ toText abbrev, + version = "2012-01-01", + s3AddressingStyle = S3AddressingStyleAuto, + endpointPrefix = Text.encodeUtf8 . Text.toLower $ toText abbrev, + endpoint = defaultEndpoint (svc abbrev), + timeout = Nothing, + check = const False, + retry = Exponential 1 2 3 (Just . Text.pack . show), + error = \status hdrs _ -> + ServiceError $ + ServiceError' + { abbrev = abbrev, + status = status, + headers = hdrs, + code = ErrorCode "Arbitrary.Service", + message = Nothing, + requestId = Nothing + } + } + +instance Arbitrary (Request ()) where + arbitrary = + Request + <$> arbitrary + <*> 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, + GovCloudEast, + GovCloudWest, + SaoPaulo + ] + +instance Arbitrary RequestBody 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 = sized arbitraryQS + +-- | Used to limit the recursion depth. +arbitraryQS :: Int -> Gen QueryString +arbitraryQS = \case + 0 -> QPair <$> arbitrary <*> (QValue <$> arbitrary) + n -> + oneof + [ QValue <$> arbitrary, + QPair <$> arbitrary <*> arbitraryQS (n - 1), + QList <$> (take 4 <$> QC.listOf (arbitraryQS (n `div` 2))) + ] + +instance (Arbitrary a, FoldCase a) => Arbitrary (CI a) where + 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 + +instance Arbitrary (Time a) where + arbitrary = Time <$> arbitrary + +instance Arbitrary AccessKey where + arbitrary = AccessKey <$> arbitrary + +instance (Arbitrary a) => Arbitrary (Sensitive a) where + arbitrary = Sensitive <$> arbitrary + +instance Arbitrary SecretKey where + arbitrary = SecretKey . fromString <$> suchThat Unicode.string (not . null) + +instance Arbitrary SessionToken where + arbitrary = SessionToken <$> arbitrary + +instance Arbitrary AuthEnv where + arbitrary = AuthEnv <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary diff --git a/test/Test/Amazonka/Data/Base64.hs b/test/Test/Amazonka/Data/Base64.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Data/Base64.hs @@ -0,0 +1,45 @@ +-- | +-- Module : Test.Amazonka.Data.Base64 +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Data.Base64 (tests) where + +import Amazonka.Core +import Amazonka.Prelude +import Network.HTTP.Types.URI (urlEncode) +import Test.Amazonka.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/Amazonka/Data/List.hs b/test/Test/Amazonka/Data/List.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Data/List.hs @@ -0,0 +1,197 @@ +-- | +-- Module : Test.Amazonka.Data.List +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Data.List (tests) where + +import Amazonka.Core +import Amazonka.Data +import Amazonka.Prelude hiding (Item) +import Test.Amazonka.Util +import Test.Tasty + +tests :: TestTree +tests = + testGroup + "list" + [ 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])) + ] + ] + ], + testGroup + "xml" + [ testGroup + "deserialise" + [ testGroup + "non-flattened" + [ testFromXML + "absent" + "absent" + (NonFlat "absent" absent), + testFromXML + "empty" + "empty" + (NonFlat "empty" absent), + 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])) + ] + ] + ] + ] + +empty :: Maybe [Int] +empty = Just [] + +absent :: Maybe [Int] +absent = Nothing + +data NonFlat a = NonFlat Text (Maybe [a]) + deriving stock (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 stock (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 stock (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/Amazonka/Data/Maybe.hs b/test/Test/Amazonka/Data/Maybe.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Data/Maybe.hs @@ -0,0 +1,42 @@ +-- | +-- Module : Test.Amazonka.Data.Maybe +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Data.Maybe (tests) where + +import Amazonka.Data +import Amazonka.Prelude hiding (Item) +import Test.Amazonka.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 stock (Eq, Show) + +instance ToXML Item where + toXML (Item x y) = + mconcat + [ "Key" @= x, + "Num" @= y + ] diff --git a/test/Test/Amazonka/Data/Numeric.hs b/test/Test/Amazonka/Data/Numeric.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Data/Numeric.hs @@ -0,0 +1,164 @@ +-- | +-- Module : Test.Amazonka.Data.Numeric +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Data.Numeric (tests) where + +import Amazonka.Prelude +import Test.Amazonka.Util +import Test.Tasty + +tests :: TestTree +tests = + testGroup + "numeric" + [ testGroup + "json" + [ testGroup + "deserialisation" + [ testFromJSON + "natural" + "123" + (123 :: Natural), + testFromJSON + "int" + (toLazyBS maxInt) + maxInt, + 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" + (123 :: Natural), + 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) + ] + ], + testGroup + "xml" + [ testGroup + "deserialisation" + [ testFromXML + "natural" + "123" + (123 :: Natural), + testFromXML + "int" + (toLazyBS maxInt) + maxInt, + testFromXML + "negative int" + (toLazyBS minInt) + minInt, + testFromXML + "integer" + "891324" + (891324 :: Integer), + testFromXML + "negative integer" + "-998" + (-998 :: Integer), + testFromXML + "double" + "46.39212" + (46.39212 :: Double), + testFromXML + "negative double" + "-1.09231" + (-1.09231 :: Double), + testFromXML + "numeric string" + "22" + ("22" :: Text) + ], + testGroup + "serialisation" + [ testToXML + "natural" + "123" + (123 :: Natural), + testToXML + "int" + (toLazyBS maxInt) + maxInt, + testToXML + "negative int" + (toLazyBS minInt) + minInt, + testToXML + "integer" + "891324" + (891324 :: Integer), + 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/Amazonka/Data/Path.hs b/test/Test/Amazonka/Data/Path.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Data/Path.hs @@ -0,0 +1,31 @@ +-- | +-- Module : Test.Amazonka.Data.Path +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Data.Path (tests) where + +import Amazonka.Data +import Amazonka.Prelude +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "path" + [ testGroup + "encode" + [ testCase "doesn't append trailing slash" $ + let x = "/path/without/trailing/slash" in encode x @?= x, + testCase "preserves trailing slash" $ + let x = "/some/path/with/trailing/slash/" in encode x @?= x, + testCase "preserves adjacent slashes" $ + let x = "/path//with/adjacent///slahes/" in encode x @?= x + ] + ] + +encode :: ByteString -> ByteString +encode = toBS . escapePath . rawPath diff --git a/test/Test/Amazonka/Data/Query.hs b/test/Test/Amazonka/Data/Query.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Data/Query.hs @@ -0,0 +1,52 @@ +-- | +-- Module : Test.Amazonka.Query.List +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Data.Query (tests) where + +import Amazonka.Data +import Amazonka.Prelude +import Test.Tasty +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "query" + [ testGroup + "fromString" + [ testCase "key" $ + parseQueryString "foo" + @?= QList + [ QPair "foo" (QValue Nothing) + ], + testCase "key=" $ + parseQueryString "foo=" + @?= QList + [ QPair "foo" (QValue Nothing) + ], + testCase "key=value" $ + parseQueryString "foo=bar" + @?= QList + [ QPair "foo" (QValue (Just "bar")) + ], + testCase "key&.." $ + parseQueryString "foo&bar&baz" + @?= QList + [ QPair "foo" (QValue Nothing), + QPair "bar" (QValue Nothing), + QPair "baz" (QValue Nothing) + ], + testCase "key=value&.." $ + parseQueryString "foo=1&bar=2&baz&qux=3" + @?= QList + [ QPair "foo" (QValue (Just "1")), + QPair "bar" (QValue (Just "2")), + QPair "baz" (QValue Nothing), + QPair "qux" (QValue (Just "3")) + ] + ] + ] diff --git a/test/Test/Amazonka/Data/Time.hs b/test/Test/Amazonka/Data/Time.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Data/Time.hs @@ -0,0 +1,173 @@ +-- | +-- Module : Test.Amazonka.Data.Time +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Data.Time (tests) where + +import Amazonka.Data +import Amazonka.Prelude +import qualified Data.Time as Time +import Test.Amazonka.Util +import Test.Tasty + +tests :: TestTree +tests = + testGroup + "time" + [ testGroup + "text" + [ testGroup + "deserialise" + [ testFromText + "rfc822 - UTC" + "Fri, 07 Nov 2014 04:42:13 UTC" + (time :: RFC822), + testFromText + "rfc822 - GMT" + "Fri, 07 Nov 2014 04:42:13 GMT" + (time :: RFC822), + testFromText + "rfc822 - PST" + "Fri, 06 Nov 2014 20:42:13 PST" + (time :: RFC822), + testFromText + "iso8601" + "2014-11-07T04:42:13.000Z" + (time :: ISO8601), + testFromText + "aws" + "20141107T044213Z" + (time :: AWSTime) + ], + testGroup + "serialise" + [ testToText + "rfc822" + "Fri, 07 Nov 2014 04:42:13 GMT" + (time :: RFC822), + testToText + "iso8601" + "2014-11-07T04:42:13Z" + (time :: ISO8601), + testToText + "aws" + "20141107T044213Z" + (time :: AWSTime) + ] + ], + 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%3A13Z" + (time :: ISO8601), + testToQuery + "aws" + "x=20141107T044213Z" + (time :: AWSTime) + ] + ], + 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 + "serialise" + [ testToXML + "rfc822" + "Fri, 07 Nov 2014 04:42:13 GMT" + (time :: RFC822), + testToXML + "iso8601" + "2014-11-07T04:42:13Z" + (time :: ISO8601), + testToXML + "aws" + "20141107T044213Z" + (time :: AWSTime) + ] + ], + testGroup + "json" + [ testGroup + "deserialise" + [ testFromJSON + "rfc822" + (str "Fri, 07 Nov 2014 04:42:13 GMT") + (time :: RFC822), + testFromJSON + "iso8601" + (str "2014-11-07T04:42:13.000Z") + (time :: ISO8601), + testFromJSON + "aws" + (str "20141107T044213Z") + (time :: AWSTime), + 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:13Z") + (time :: ISO8601), + testToJSON + "aws" + (str "20141107T044213Z") + (time :: AWSTime), + testToJSON + "posix" + "1415335333" + (time :: POSIX) + ] + ] + ] + +time :: Time a +time = + Time . fromMaybe (error msg) $ + Time.parseTimeM True Time.defaultTimeLocale fmt ts + where + msg = "Unable to parse time: " ++ ts + fmt = "%FT%H:%M:%S" + ts = "2014-11-07T04:42:13" diff --git a/test/Test/Amazonka/Error.hs b/test/Test/Amazonka/Error.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Error.hs @@ -0,0 +1,85 @@ +-- | +-- Module : Test.Amazonka.Error +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Error (tests) where + +import Amazonka.Core +import Amazonka.Data +import Amazonka.Prelude +import Network.HTTP.Types.Status (status400, status404) +import Test.Amazonka.Arbitrary () +import Test.QuickCheck.Property () +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "errors" + [ testGroup + "getErrorCode" + [ testCase "with header, colon" $ + getErrorCode status404 [(hAMZNErrorType, "ResourceNotFoundException")] + @?= ErrorCode "ResourceNotFound", + testCase "with header, no colon" $ + getErrorCode status404 [(hAMZNErrorType, "ResourceNotFoundException:http://iot.amazonaws.com/doc/2015-10-02/")] + @?= ErrorCode "ResourceNotFound", + testCase "no header" $ + getErrorCode status400 [] + @?= ErrorCode "Bad Request" + ], + testGroup + "xml" + [ testCase "ec2" $ + xmlError + ec2 + "VolumeInUse" + "vol-8c8cea98 is already attached to an instance" + "c0ca7700-c515-4653-87e3-f1a9ce6416e8", + testCase "route53" $ + xmlError + route53 + "InvalidChangeBatch" + "Tried to delete resource record set noexist.example.com. type A,but it was not found" + "default_rid", + testCase "sqs" $ + xmlError + sqs + "InvalidParameterValue" + "Value (quename_nonalpha) for parameter QueueName is invalid. Must be an alphanumeric String of 1 to 80 in length" + "42d59b56-7407-4c4a-be0f-4c88daeea257" + ] + ] + +xmlError :: + ByteStringLazy -> + ErrorCode -> + ErrorMessage -> + RequestId -> + Assertion +xmlError bs c m r = actual @?= Right expect + where + expect = serviceError a s h (Just c) (Just m) (Just r) + actual = + case parseXMLError a s h bs of + ServiceError e -> Right e + e -> Left $ "unexpected error: " ++ show e + + a = "Test" + s = toEnum 400 + h = [(hAMZRequestId, "default_rid")] + +-- Samples representative of differing xml errors. + +ec2 :: ByteStringLazy +ec2 = "VolumeInUsevol-8c8cea98 is already attached to an instancec0ca7700-c515-4653-87e3-f1a9ce6416e8" + +route53 :: ByteStringLazy +route53 = "Tried to delete resource record set noexist.example.com. type A,but it was not found" + +sqs :: ByteStringLazy +sqs = "SenderInvalidParameterValueValue (quename_nonalpha) for parameter QueueName is invalid. Must be an alphanumeric String of 1 to 80 in length42d59b56-7407-4c4a-be0f-4c88daeea257" diff --git a/test/Test/Amazonka/Sign/V2Header.hs b/test/Test/Amazonka/Sign/V2Header.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Sign/V2Header.hs @@ -0,0 +1,283 @@ +-- | +-- Module : Test.Amazonka.Sign.V2Header.BaseSpec +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Sign.V2Header (tests) where + +import Amazonka.Data hiding (length) +import Amazonka.Prelude +import Amazonka.Sign.V2Header +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.CaseInsensitive as CI +import qualified Data.List as List +import Data.List.Ordered (subset) +import qualified Data.Text as Text +import qualified Network.HTTP.Types as HTTP +import qualified Test.QuickCheck as QC +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (Gen, Property, testProperty) + +tests :: TestTree +tests = + testGroup + "v2Header.BaseSpec" + [ testGroup + "constructSigningQuery" + [ testProperty + "should always convert set QValues to Nothing" + prop_QValueEmpty, + testCase "should keep an unset QValue" $ + constructSigningQuery (QValue (Nothing :: Maybe ByteString)) @?= QValue (Nothing :: Maybe ByteString), + testProperty + "should discard QPairs that are not interesting to AWS" + prop_UninterestingQPairs, + testProperty + "should keep all QPairs that are interesting to AWS" + prop_InterestingQPairs, + testCase "should keep an empty QList" $ + constructSigningQuery (QList []) @?= QList [], + testCase "should keep a list of Nothing QValues" $ + constructSigningQuery (QList [QValue Nothing]) @?= QList [QValue Nothing], + testProperty + "should discard the contents of an unintersting QList" + prop_UninterestingQLists, + testProperty + "should not discard all QC.elements in interesting QLists" + prop_InterestingQLists + ], + testGroup + "constructSigningHeader" + [ testProperty + "should convert random headers to their header value" + prop_RandomHeaders, + testProperty + "should convert interesting headers to their header value" + prop_InterestingHeaders, + testProperty + "should convert aws headers to a canonical string" + prop_InterestingAwsHeaders + ], + testGroup + "auxiliary headers functions" + [ testProperty + "should sort and preserve headers" + prop_SortedHeaders, + testCase "should contain empty md5 and empty content type headers if not present" $ + [(HTTP.hContentMD5, ""), (HTTP.hContentType, "")] `subset` unionNecessaryHeaders [] @?= True, + testCase "should preserve a set md5 and contain an empty content type header if not present" $ + [(HTTP.hContentMD5, "123"), (HTTP.hContentType, "")] `subset` unionNecessaryHeaders [(HTTP.hContentMD5, "123")] @?= True, + testCase "should preserve a set content type and preserve an empty md5 header if not present" $ + [(HTTP.hContentType, "123"), (HTTP.hContentMD5, "")] `subset` unionNecessaryHeaders [(HTTP.hContentType, "123")] @?= True, + testCase "should preserve md5 and content type headers if set" $ + [(HTTP.hContentType, "123"), (HTTP.hContentMD5, "456")] `subset` unionNecessaryHeaders [(HTTP.hContentType, "123"), (HTTP.hContentMD5, "456")] @?= True + ], + testGroup + "toSingerQBS" + [ testCase "should convert an empty query string" $ + toSignerQueryBS (QValue Nothing) @?= "", + testCase "should convert an empty value of QPair to just the key" $ + toSignerQueryBS (QPair "key" (QValue Nothing)) @?= "key", + testCase "should convert an empty value of QPair followed by QValue to just the key and just the value" $ + toSignerQueryBS + (QList [QPair "key" (QValue Nothing), QValue $ Just "key2"]) + @?= "key&key2" + ], + testGroup + "constructFullPath" + [ testCase "should convert an empty queryString to just the path" $ + constructFullPath "path" "" @?= "path", + testCase "should convert an empty value of QPair and a path to just the path and the key" $ + constructFullPath "path" (toSignerQueryBS (QPair "key" (QValue Nothing))) @?= "path?key" + ], + testGroup + "should construct canonical headers" + [ testCase "should construct a canonical header from a base string" $ + newSigner [] "GET" "\\" "" @?= "GET\n\n\n\\" + ] + ] + +-- Properties for non-empty QValues + +prop_QValueEmpty :: Property +prop_QValueEmpty = + QC.forAll uninterestingQValues $ \qv -> + constructSigningQuery qv + == QValue (Nothing :: Maybe ByteString) + +-- Generators / properties for uninteresting query pairs + +prop_UninterestingQPairs :: Property +prop_UninterestingQPairs = + QC.forAll uninterestingQPairs $ \qpair -> + constructSigningQuery qpair == QValue Nothing + +uninterestingQPairs :: Gen QueryString +uninterestingQPairs = + toQuery <$> ((,) <$> nonEmptyText <*> uninterestingQValues) + +-- Generators / properties for interesting query pairs + +prop_InterestingQPairs :: Property +prop_InterestingQPairs = + QC.forAll interestingQPairs $ \qpair -> + constructSigningQuery qpair /= QValue Nothing + +interestingQueryKey :: Gen ByteString +interestingQueryKey = + QC.elements + [ "acl", + "cors", + "defaultObjectAcl", + "location", + "logging", + "partNumber", + "policy", + "requestPayment", + "torrent", + "versioning", + "versionId", + "versions", + "website", + "uploads", + "uploadId", + "response-content-type", + "response-content-language", + "response-expires", + "response-cache-control", + "response-content-disposition", + "response-content-encoding", + "delete", + "lifecycle", + "tagging", + "restore", + "storageClass", + "websiteConfig", + "compose" + ] + +interestingQPairs :: Gen QueryString +interestingQPairs = + toQuery <$> ((,) <$> interestingQueryKey <*> uninterestingQValues) + +-- Generators / properties for query lists + +prop_UninterestingQLists :: Property +prop_UninterestingQLists = + QC.forAll uninterestingQLists $ + not . containsAnything . constructSigningQuery + +uninterestingQLists :: Gen QueryString +uninterestingQLists = + toQueryList + <$> nonEmptyByteString + <*> QC.listOf + ( QC.frequency + [ (1, uninterestingQPairs), + (1, uninterestingQValues), + (1, uninterestingQLists) + ] + ) + +containsAnything :: QueryString -> Bool +containsAnything = \case + QValue v -> isJust v + QPair {} -> True + QList qs -> any containsAnything qs + +interestingQLists :: Gen QueryString +interestingQLists = + toQueryList + <$> interestingQueryKey + <*> QC.listOf + ( QC.frequency + [ (1, interestingQLists), + (1, uninterestingQPairs), + (1, uninterestingQValues), + (1, uninterestingQLists) + ] + ) + +-- this property should probably be expanded to check that all qpairs actually contain interesting query keys AND that uninteresting +-- query keys are actually preserved underneath an interesting one +prop_InterestingQLists :: Property +prop_InterestingQLists = + QC.forAll interestingQLists $ + containsAnything . constructSigningQuery + +prop_RandomHeaders :: Property +prop_RandomHeaders = + QC.forAll randomHeaderGenerator $ \hs -> + constructSigningHeader hs == snd hs + +prop_InterestingHeaders :: Property +prop_InterestingHeaders = + QC.forAll interestingHeaderGenerator $ \hs -> + constructSigningHeader hs == snd hs + +prop_InterestingAwsHeaders :: Property +prop_InterestingAwsHeaders = + QC.forAll interestingAwsHeaderGenerator $ \hs -> + constructSigningHeader hs + == (CI.foldedCase (fst hs) <> ":" <> snd hs) + +-- Generator / Property for headers +randomHeaderGenerator :: Gen HTTP.Header +randomHeaderGenerator = + (,) <$> (CI.mk <$> nonEmptyByteString) <*> nonEmptyByteString + +interestingAwsHeaderName :: Gen HTTP.HeaderName +interestingAwsHeaderName = + CI.mk . BS8.pack <$> fmap ("aws-" <>) nonEmptyString + +interestingHeaderName :: Gen HTTP.HeaderName +interestingHeaderName = + QC.elements [HTTP.hContentMD5, HTTP.hContentType, HTTP.hDate] + +interestingHeaderGenerator :: Gen HTTP.Header +interestingHeaderGenerator = + (,) <$> interestingHeaderName <*> nonEmptyByteString + +interestingAwsHeaderGenerator :: Gen HTTP.Header +interestingAwsHeaderGenerator = + (,) <$> interestingAwsHeaderName <*> nonEmptyByteString + +-- Generators / Properties for auxiliary header functions + +prop_SortedHeaders :: Property +prop_SortedHeaders = + QC.forAll allHeadersGenerator $ \allHeaders -> testHeaders allHeaders + +allHeadersGenerator :: Gen [HTTP.Header] +allHeadersGenerator = + QC.listOf $ + QC.frequency + [ (1, interestingHeaderGenerator), + (1, interestingAwsHeaderGenerator) + ] + +allIncreasing :: [HTTP.Header] -> Bool +allIncreasing xs = + and $ zipWith (<=) mapped $ drop 1 mapped + where + mapped = map fst xs + +testHeaders :: [HTTP.Header] -> Bool +testHeaders headers = + length headers == length sortedHeaders && allIncreasing sortedHeaders + where + sortedHeaders = List.sort headers + +-- Generators for Text / QueryValues + +nonEmptyByteString :: Gen ByteString +nonEmptyByteString = BS8.pack <$> nonEmptyString + +uninterestingQValues :: Gen QueryString +uninterestingQValues = toQuery <$> nonEmptyText + +nonEmptyText :: Gen Text.Text +nonEmptyText = Text.pack <$> nonEmptyString + +nonEmptyString :: Gen String +nonEmptyString = QC.listOf1 QC.arbitrary diff --git a/test/Test/Amazonka/Sign/V4.hs b/test/Test/Amazonka/Sign/V4.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Sign/V4.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Test.Amazonka.Sign.V$ +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Sign.V4 (tests) where + +import qualified Test.Amazonka.Sign.V4.Base as Base +import qualified Test.Amazonka.Sign.V4.Chunked as Chunked +import Test.Tasty (TestTree, testGroup) + +-- 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 + "base" + [ Base.tests + ], + testGroup + "chunked" + [ Chunked.tests + ] + ] diff --git a/test/Test/Amazonka/Sign/V4/Base.hs b/test/Test/Amazonka/Sign/V4/Base.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Sign/V4/Base.hs @@ -0,0 +1,190 @@ +-- | +-- Module : Test.AWS.Sign.V4 +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Sign.V4.Base where + +import Amazonka.Core +import Amazonka.Data +import Amazonka.Prelude +import Amazonka.Sign.V4 +import Amazonka.Sign.V4.Base as Base +import qualified Data.Foldable as Fold +import Test.Amazonka.Arbitrary () +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Property () +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "paths" + [ testProperty "request paths are escaped once" testRequestPathsEscapedOnce, + testProperty "S3 canonical paths are escaped once" testS3CanonicalPathsEscapedOnce, + testProperty "non-S3 canonical paths are escaped twice" testNonS3CanonicalPathsEscapedTwice, + testCase "empty path" testEmptyPath, + testCase "base path" testBasePath, + testCase "S3 canonical path encoding example" testS3CanonicalPathExample, + testCase "non-S3 canonical path encoding example" testNonS3CanonicalPathExample, + testCase "S3 canonical path is not normalized" testS3ShouldNotNormalize, + testCase "non-S3 canonical path is normalized" testNonS3ShouldNormalize + ] + +testRequestPathsEscapedOnce :: Property +testRequestPathsEscapedOnce = QC.forAll (mkV4Paths args) $ \(raw, reqPath, _) -> + untag reqPath == toBS (escapePath raw) + where + args = + V4PathArgs + { genAbbrev = arbitrary, + genBasePath = mkNormalizedPath, + genPath = mkNormalizedPath + } + +testS3CanonicalPathsEscapedOnce :: Property +testS3CanonicalPathsEscapedOnce = QC.forAll (mkV4Paths args) $ \(_, reqPath, canonicalPath') -> + untag reqPath == untag canonicalPath' + where + args = + V4PathArgs + { genAbbrev = pure "S3", + genBasePath = mkNormalizedPath, + genPath = mkNormalizedPath + } + +testNonS3CanonicalPathsEscapedTwice :: Property +testNonS3CanonicalPathsEscapedTwice = QC.forAll (mkV4Paths args) $ \(raw, _, canonicalPath') -> + untag canonicalPath' == toBS (escapePathTwice raw) + where + args = + V4PathArgs + { genAbbrev = mkNonS3Service, + genBasePath = mkNormalizedPath, + genPath = mkNormalizedPath + } + +testEmptyPath :: Assertion +testEmptyPath = do + (_, reqPath, canonicalPath') <- + generate . mkV4Paths $ + V4PathArgs + { genAbbrev = arbitrary, + genBasePath = pure mempty, + genPath = pure mempty + } + toBS reqPath @?= "/" + toBS canonicalPath' @?= "/" + +testBasePath :: Assertion +testBasePath = do + basePath <- generate arbitrary + path <- generate arbitrary + (_, reqPath, _) <- + generate . mkV4Paths $ + V4PathArgs + { genAbbrev = arbitrary, + genBasePath = pure basePath, + genPath = pure path + } + toBS reqPath @?= toBS (escapePath $ basePath <> path) + +testNonS3CanonicalPathExample :: Assertion +testNonS3CanonicalPathExample = do + let example = Raw ["documents and settings"] + + (_, reqPath, canonicalPath') <- + generate . mkV4Paths $ + V4PathArgs + { genAbbrev = mkNonS3Service, + genBasePath = pure mempty, + genPath = pure example + } + toBS reqPath @?= "/documents%20and%20settings" + toBS canonicalPath' @?= "/documents%2520and%2520settings" + +testS3CanonicalPathExample :: Assertion +testS3CanonicalPathExample = do + let example = Raw ["documents and settings"] + + (_, reqPath, canonicalPath') <- + generate . mkV4Paths $ + V4PathArgs + { genAbbrev = pure "S3", + genBasePath = pure mempty, + genPath = pure example + } + toBS reqPath @?= "/documents%20and%20settings" + untag canonicalPath' @?= untag reqPath + +testS3ShouldNotNormalize :: Assertion +testS3ShouldNotNormalize = do + let key = Raw ["foo", "..", "bar", ".", "baz", "."] + + (_, reqPath, canonicalPath') <- + generate . mkV4Paths $ + V4PathArgs + { genAbbrev = pure "S3", + genBasePath = pure mempty, + genPath = pure key + } + toBS reqPath @?= "/foo/../bar/./baz/." + untag canonicalPath' @?= untag reqPath + +testNonS3ShouldNormalize :: Assertion +testNonS3ShouldNormalize = do + let key = Raw ["foo", "..", "bar", ".", "baz", "."] + + (_, reqPath, canonicalPath') <- + generate . mkV4Paths $ + V4PathArgs + { genAbbrev = mkNonS3Service, + genBasePath = pure mempty, + genPath = pure key + } + toBS reqPath @?= "/bar/baz" + untag canonicalPath' @?= untag reqPath + +data V4PathArgs = V4PathArgs + { genAbbrev :: Gen Abbrev, + genBasePath :: Gen RawPath, + genPath :: Gen RawPath + } + +mkV4Paths :: V4PathArgs -> Gen (RawPath, Base.Path, CanonicalPath) +mkV4Paths V4PathArgs {..} = do + aReq <- arbitrary :: Gen (Request ()) + aBasePath <- genBasePath + aPath <- genPath + aService@Service {endpoint} <- arbitrary + anAbbrev <- genAbbrev + aBody <- toHashed <$> (arbitrary :: Gen ByteString) + + let reg = NorthVirginia + end = endpoint reg + svc = + aService + { signer = v4, + abbrev = anAbbrev, + endpoint = const $ end {basePath = aBasePath} + } + req = + aReq + { path = aPath, + service = svc, + body = Hashed aBody + } + + pure (fullRawPath reg req, escapedPath reg req, canonicalPath reg req) + +mkNormalizedPath :: Gen RawPath +mkNormalizedPath = arbitrary `suchThat` noDots + where + noDots (Raw xs :: RawPath) = isNothing $ Fold.find (\x -> x == "." || x == "..") xs + +mkNonS3Service :: Gen Abbrev +mkNonS3Service = arbitrary `suchThat` (/= "S3") diff --git a/test/Test/Amazonka/Sign/V4/Chunked.hs b/test/Test/Amazonka/Sign/V4/Chunked.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Sign/V4/Chunked.hs @@ -0,0 +1,83 @@ +-- | +-- Module : Test.Amazonka.Sign.V$ +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Sign.V4.Chunked (tests) where + +import Amazonka.Core hiding (length) +import Amazonka.Prelude hiding (elem) +import Amazonka.Sign.V4 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Conduit.List as Conduit +import qualified Data.Foldable as Fold +import qualified Network.HTTP.Conduit as Client +import Numeric (showHex) +import Test.Amazonka.Arbitrary () +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Property () +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "headers" + [ testProperty "empty body" testEmptyBody, + testProperty "1 chunk body" testOneChunkBody, + testProperty "2 chunks body" testTwoChunksBody + ] + +testEmptyBody :: Property +testEmptyBody = + QC.forAll (mkSigned []) $ \Signed {..} -> + let elem = (`Fold.elem` Client.requestHeaders signedRequest) + in elem ("X-Amz-Decoded-Content-Length", "0") + && elem ("Content-Length", "86") + +testOneChunkBody :: Property +testOneChunkBody = + let n = 123 + str = BS8.pack . show + inp = BS8.replicate n 'a' + in QC.forAll (mkSigned [inp]) $ \Signed {..} -> + let elem = (`Fold.elem` Client.requestHeaders signedRequest) + in elem ("X-Amz-Decoded-Content-Length", str n) + && elem ("Content-Length", str (87 + n + 86)) + +testTwoChunksBody :: Property +testTwoChunksBody = + let size = fromIntegral defaultChunkSize + sizeLen = length (showHex size "") + n = 123 + str = BS8.pack . show + full = BS8.replicate size 'a' -- full-sized chunk + final = BS8.replicate n 'b' -- final non-empty chunk + in QC.forAll (mkSigned [full, final]) $ \Signed {..} -> + let elem = (`Fold.elem` Client.requestHeaders signedRequest) + in elem ("X-Amz-Decoded-Content-Length", str (size + n)) + && elem ("Content-Length", str (sizeLen + 85 + size + 87 + n + 86)) + +mkSigned :: [BS8.ByteString] -> Gen (Signed ()) +mkSigned bs = do + aReq <- arbitrary :: Gen (Request ()) + aService <- arbitrary + + let svc = aService {signer = v4} + + req = + aReq + { body = Chunked (mkBody bs), + service = svc + } + + requestSign req <$> arbitrary <*> arbitrary <*> arbitrary + +mkBody :: [BS8.ByteString] -> ChunkedBody +mkBody bs = + ChunkedBody + defaultChunkSize + (fromIntegral . sum $ fmap BS8.length bs) + (Conduit.sourceList bs) diff --git a/test/Test/Amazonka/Util.hs b/test/Test/Amazonka/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Amazonka/Util.hs @@ -0,0 +1,121 @@ +-- | +-- Module : Test.Amazonka.Util +-- Copyright : (c) 2013-2023 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Test.Amazonka.Util where + +import Amazonka.Data +import Amazonka.Prelude +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS +import Language.Haskell.TH +import Language.Haskell.TH.Quote +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 stock (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 -> + ByteStringLazy -> + a -> + TestTree +testFromXML n bs x = + testCase n $ + Right (X x) @?= (decodeXML (wrapXML bs) >>= parseXML) + +testToXML :: + (ToXML a, Show a, Eq a) => + TestName -> + ByteStringLazy -> + a -> + TestTree +testToXML n bs x = testCase n $ wrapXML bs @?= encodeXML (X x) + +testFromJSON :: + (FromJSON a, Show a, Eq a) => + TestName -> + ByteStringLazy -> + a -> + TestTree +testFromJSON n bs x = + testCase n $ + Right (X x) @?= eitherDecode' ("{\"x\":" <> bs <> "}") + +testToJSON :: + (ToJSON a, Show a, Eq a) => + TestName -> + ByteStringLazy -> + a -> + TestTree +testToJSON n bs x = testCase n (bs @?= Aeson.encode x) + +str :: ByteStringLazy -> ByteStringLazy +str bs = "\"" <> bs <> "\"" + +wrapXML :: ByteStringLazy -> ByteStringLazy +wrapXML bs = + "" <> "" <> bs <> "" + +maxInt :: Int +maxInt = maxBound + +minInt :: Int +minInt = minBound + +toLazyBS :: ToByteString a => a -> ByteStringLazy +toLazyBS = LBS.fromStrict . toBS