aws-0.13.0/0000755000000000000000000000000012615132266010557 5ustar0000000000000000aws-0.13.0/LICENSE0000644000000000000000000000301212615132266011560 0ustar0000000000000000Copyright (c) 2010, 2011, 2012, Aristid Breitkreuz All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Aristid Breitkreuz nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. aws-0.13.0/CHANGELOG0000644000000000000000000001727412615132266012004 0ustar0000000000000000 ** 0.13 series NOTE: 0.13 brings breaking changes compared to 0.12.1! - 0.13 - DDB: Add support for scanning an index - DDB: Allow deleting an attribute on update - DDB: !BREAKING! Add support for native boolean values via "Bool". Can read old values, and there's a compatibility wrapper OldBool that behaves exactly the same way it used to. - DDB: Add support for Null, L (list) and M (map) data types. - DDB: Support consistent reads in Scan requests - IAM: Add list-mfa-devices command - S3: Extend StorageClass to support arbitrary classes, and StandardInfrequentAccess - S3: Add a Sink interface for multipart uploading - S3: Performance improvement for chunkedConduit - S3: Partial support for Google Nearline ** 0.12 series - 0.12.1 - DDB: Fix eu-west-1, add eu-central-1 - attoparsec 0.13 - xml-conduit 1.3 - 0.12 - S3: Support for "Expect: 100-continue" (optional, technically API breaking) - S3: Properly treat errors with a "301 Permanent Redirect" as errors and expose endpoint information ** 0.11 series - 0.11.4 - Url-encode S3 object names in URLs - filepath 1.4 - tagged 0.8.x - limit errors to <2 to avoid compatibility problems - 0.11.3 - Support for blaze-builder 0.4 - Support for utf8-string 1.0 - New function: multipartUploadWithInitiator - Fix issue in DynamoDB error parsing - Ord instance for Aws.Core.Method - 0.11.2 - Support for time 1.5 (we previously forgot to relax the upper bound in Cabal) - 0.11.1 - Support time 1.5 - Fix duplicate sending of query when using PostQuery - 0.11 - New functions for running AWS transactions - Performance optimizations for DynamoDB and S3 MultiPartUpload - New DynamoDB commands & features - S3 endpoint eu-central-1 ** 0.10 series - 0.10.5 - support for conduit 1.2 - 0.10.4 - S3: support for multi-part uploads - DynamoDB: fixes for JSON serialization WARNING: This includes making some fields in TableDescription Maybe fields, which is breaking. But DynamoDB support was and is also marked as EXPERIMENTAL. - DynamoDB: TCP connection reuse where possible (improving performance) - DynamoDB: Added test suite - SES: support for additional regions - 0.10.3 - fix bug introduced in 0.10.2 that broke SQS and IAM connections without STS - 0.10.2 - support STS / IAM temporary credentials in all services - 0.10 - [EXPERIMENTAL!] DynamoDB: support for creating/updating/querying and scanning items - SQS: complete overhaul to support 2012-11-05 features - SQS: test suite - S3: use Maybe for 404 HEAD requests on objects instead of throwing a misleading exception - S3: support of poAutoMakeBucket for Internet Archive users - S3: implement GetBucketLocation - S3: add South American region - S3: allow specifying the Content-Type when copying objects - core: fix typo in NoCredentialsException accessor ** 0.9 series - 0.9.4 - allow conduit 1.2 - 0.9.3 - fix performance regression for loadCredentialsDefault - add generic makeCredentials function - add S3 DeleteBucket operation - add S3 NukeBucket example - SES: use security token if enabled (should allow using it with IAM roles on EC2 instances) - 0.9.2 - Support for credentials from EC2 instance metadata (only S3 for now) - aeson 0.8 compatibility - 0.9.1 - Support for multi-page S3 GetBucket requests - S3 GLACIER support - Applicative instance for Response to conform to the Applicative-Monad Proposal - Compatibility with transformers 0.4 - 0.9 - Interface changes: - attempt and failure were deprecated, remove - switch to new cryptohash interface - updated version bounds of conduit and xml-conduit ** 0.8 series - 0.8.6 - move Instance metadata functions out of ResourceT to remove problem with exceptions-0.5 (this makes a fresh install of aws on a clean system possible again) - 0.8.5 - compatibility with case-insensitive 1.2 - support for V4 signatures - experimental support for DynamoDB - 0.8.4 - compatibility with http-conduit 2.0 - 0.8.3 - compatibility with cryptohash 0.11 - experimental IAM support - 0.8.2 - compatibility with cereal 0.4.x - 0.8.1 - compatibility with case-insensitive 1.1 - 0.8.0 - S3, SQS: support for US-West2 (#58) - S3: GetObject now has support for Content-Range (#22, #50) - S3: GetBucket now supports the "IsTruncated" flag (#39) - S3: PutObject now supports web page redirects (#46) - S3: support for (multi-object) DeleteObjects (#47, #56) - S3: HeadObject now uses an actual HEAD request (#53) - S3: fixed signing issues for GetObject call (#54) - SES: support for many more operations (#65, #66, #70, #71, #72, #74) - SES: SendRawEmail now correctly encodes destinations and allows multiple destinations (#73) - EC2: support fo Instance metadata (#37) - Core: queryToHttpRequest allows overriding "Date" for the benefit of Chris Dornan's Elastic Transcoder bindings (#77) ** 0.7 series - 0.7.6.4 - CryptoHash update - 0.7.6.3 - In addition to supporting http-conduit 1.9, it would seem nice to support conduit 1.0. Previously slipped through the radar. - 0.7.6.2 - Support for http-conduit 1.9 - 0.7.6.1 - Support for case-insensitive 1.0 and http-types 0.8 - 0.7.6 - Parsing of SimpleDB error responses was too strict, fixed - Support for cryptohash 0.8 - Failure 0.1 does not work with aws, stricter lower bound - 0.7.5 - Support for http-conduit 1.7 and 1.8 - 0.7.1-0.7.4 - Support for GHC 7.6 - Wider constraints to support newer versions of various dependencies - Update maintainer e-mail address and project categories in cabal file - 0.7.0 - Change ServiceConfiguration concept so as to indicate in the type whether this is for URI-only requests (i.e. awsUri) - EXPERIMENTAL: Direct support for iterated transaction, i.e. such where multiple HTTP requests might be necessary due to e.g. response size limits. - Put aws functions in ResourceT to be able to safely return Sources and streams. - simpleAws* does not require ResourceT and converts streams into memory values (like ByteStrings) first. - Log response metadata (level Info), and do not let all aws runners return it. - S3: - GetObject: No longer require a response consumer in the request, return the HTTP response (with the body as a stream) instead. - Add CopyObject (PUT Object Copy) request type. - Add Examples cabal flag for building code examples. - Many more, small improvements. ** 0.6 series - 0.6.2 - Properly parse Last-Modified header in accordance with RFC 2616. - 0.6.1 - Fix for MD5 encoding issue in S3 PutObject requests. - 0.6.0 - API Cleanup - General: Use Crypto.Hash.MD5.MD5 when a Content-MD5 hash is required, instead of ByteString. - S3: Made parameter order to S3.putObject consistent with S3.getObject. - Updated dependencies: - conduit 0.5 (as well as http-conduit 1.5 and xml-conduit 1.0). - http-types 0.7. - Minor changes. - Internal changes (notable for people who want to add more commands): - http-types' new 'QueryLike' interface allows creating query lists more conveniently. ** 0.5 series - 0.5.0 :: New configuration system: configuration split into general and service-specific parts. Significantly improved API reference documentation. Re-organised modules to make library easier to understand. Smaller improvements. ** 0.4 series - 0.4.1 :: Documentation improvements. - 0.4.0.1 :: Change dependency bounds to allow the transformers 0.3 package. - 0.4.0 :: Update conduit to 0.4.0, which is incompatible with earlier versions. ** 0.3 series - 0.3.2 :: Add awsRef / simpleAwsRef request variants for those who prefer an =IORef= over a =Data.Attempt.Attempt= value. Also improve README and add simple example. aws-0.13.0/aws.cabal0000644000000000000000000002757312615132266012353 0ustar0000000000000000Name: aws Version: 0.13.0 Synopsis: Amazon Web Services (AWS) for Haskell Description: Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at . Homepage: http://github.com/aristidb/aws License: BSD3 License-file: LICENSE Author: Aristid Breitkreuz, contributors see README Maintainer: aristidb@gmail.com Copyright: See contributors list in README and LICENSE file Category: Network, Web, AWS, Cloud, Distributed Computing Build-type: Simple Extra-source-files: README.org CHANGELOG Examples/GetObject.hs Examples/SimpleDb.hs Cabal-version: >=1.10 Source-repository this type: git location: https://github.com/aristidb/aws.git tag: 0.13.0 Source-repository head type: git location: https://github.com/aristidb/aws.git Flag Examples Description: Build the examples. Default: False Library Exposed-modules: Aws Aws.Aws Aws.Core Aws.DynamoDb Aws.DynamoDb.Commands Aws.DynamoDb.Commands.DeleteItem Aws.DynamoDb.Commands.GetItem Aws.DynamoDb.Commands.PutItem Aws.DynamoDb.Commands.Query Aws.DynamoDb.Commands.Scan Aws.DynamoDb.Commands.Table Aws.DynamoDb.Commands.UpdateItem Aws.DynamoDb.Core Aws.Ec2.InstanceMetadata Aws.Iam Aws.Iam.Commands Aws.Iam.Commands.CreateAccessKey Aws.Iam.Commands.CreateUser Aws.Iam.Commands.DeleteAccessKey Aws.Iam.Commands.DeleteUser Aws.Iam.Commands.DeleteUserPolicy Aws.Iam.Commands.GetUser Aws.Iam.Commands.GetUserPolicy Aws.Iam.Commands.ListAccessKeys Aws.Iam.Commands.ListMfaDevices Aws.Iam.Commands.ListUserPolicies Aws.Iam.Commands.ListUsers Aws.Iam.Commands.PutUserPolicy Aws.Iam.Commands.UpdateAccessKey Aws.Iam.Commands.UpdateUser Aws.Iam.Core Aws.Iam.Internal Aws.Network Aws.S3 Aws.S3.Commands Aws.S3.Commands.CopyObject Aws.S3.Commands.DeleteBucket Aws.S3.Commands.DeleteObject Aws.S3.Commands.DeleteObjects Aws.S3.Commands.GetBucket Aws.S3.Commands.GetBucketLocation Aws.S3.Commands.GetObject Aws.S3.Commands.GetService Aws.S3.Commands.HeadObject Aws.S3.Commands.PutBucket Aws.S3.Commands.PutObject Aws.S3.Commands.Multipart Aws.S3.Core Aws.Ses Aws.Ses.Commands Aws.Ses.Commands.DeleteIdentity Aws.Ses.Commands.GetIdentityDkimAttributes Aws.Ses.Commands.GetIdentityNotificationAttributes Aws.Ses.Commands.GetIdentityVerificationAttributes Aws.Ses.Commands.ListIdentities Aws.Ses.Commands.SendRawEmail Aws.Ses.Commands.SetIdentityDkimEnabled Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled Aws.Ses.Commands.SetIdentityNotificationTopic Aws.Ses.Commands.VerifyDomainDkim Aws.Ses.Commands.VerifyDomainIdentity Aws.Ses.Commands.VerifyEmailIdentity Aws.Ses.Core Aws.SimpleDb Aws.SimpleDb.Commands Aws.SimpleDb.Commands.Attributes Aws.SimpleDb.Commands.Domain Aws.SimpleDb.Commands.Select Aws.SimpleDb.Core Aws.Sqs Aws.Sqs.Commands Aws.Sqs.Commands.Message Aws.Sqs.Commands.Permission Aws.Sqs.Commands.Queue Aws.Sqs.Commands.QueueAttributes Aws.Sqs.Core Build-depends: aeson >= 0.6, attoparsec >= 0.11 && < 0.14, base >= 4.6 && < 5, base16-bytestring == 0.1.*, base16-bytestring == 0.1.*, base64-bytestring == 1.0.*, blaze-builder >= 0.2.1.4 && < 0.5, byteable == 0.1.*, bytestring >= 0.9 && < 0.11, case-insensitive >= 0.2 && < 1.3, cereal >= 0.3 && < 0.5, conduit >= 1.1 && < 1.3, conduit-extra >= 1.1 && < 1.2, containers >= 0.4, cryptohash >= 0.11 && < 0.12, data-default >= 0.5.3 && < 0.6, directory >= 1.0 && < 1.3, filepath >= 1.1 && < 1.5, http-conduit >= 2.1 && < 2.2, http-types >= 0.7 && < 0.10, lifted-base >= 0.1 && < 0.3, monad-control >= 0.3, mtl == 2.*, network == 2.*, old-locale == 1.*, resourcet >= 1.1 && < 1.2, safe >= 0.3 && < 0.4, scientific >= 0.3, tagged >= 0.7 && < 0.9, text >= 0.11, time >= 1.1.4 && < 1.6, transformers >= 0.2.2 && < 0.5, unordered-containers >= 0.2, utf8-string >= 0.3 && < 1.1, vector >= 0.10, xml-conduit >= 1.2 && <1.4 if !impl(ghc >= 7.6) Build-depends: ghc-prim GHC-Options: -Wall Default-Language: Haskell2010 Default-Extensions: RecordWildCards, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, DeriveFunctor, DeriveDataTypeable, OverloadedStrings, TupleSections, ScopedTypeVariables, EmptyDataDecls, Rank2Types Executable GetObject Main-is: GetObject.hs Hs-source-dirs: Examples if !flag(Examples) Buildable: False else Buildable: True Build-depends: base == 4.*, aws, http-conduit, conduit, conduit-extra Default-Language: Haskell2010 Executable MultipartUpload Main-is: MultipartUpload.hs Hs-source-dirs: Examples if !flag(Examples) Buildable: False else Buildable: True Build-depends: base == 4.*, aws, http-conduit, conduit, conduit-extra, text, resourcet Default-Language: Haskell2010 Executable MultipartTransfer Main-is: MultipartTransfer.hs Hs-source-dirs: Examples if !flag(Examples) Buildable: False else Buildable: True Build-depends: base == 4.*, aws, http-conduit, conduit, conduit-extra, text Default-Language: Haskell2010 Executable NukeBucket Main-is: NukeBucket.hs Hs-source-dirs: Examples if !flag(Examples) Buildable: False else Buildable: True Build-depends: base == 4.*, aws, http-conduit, conduit, conduit-extra, text >=0.1, transformers Default-Language: Haskell2010 Executable PutBucketNearLine Main-is: PutBucketNearLine.hs Hs-source-dirs: Examples if !flag(Examples) Buildable: False else Buildable: True Build-depends: base == 4.*, aws, http-conduit, conduit, conduit-extra, text >=0.1, transformers Default-Language: Haskell2010 Executable SimpleDb Main-is: SimpleDb.hs Hs-source-dirs: Examples if !flag(Examples) Buildable: False else Buildable: True Build-depends: base == 4.*, aws, text >=0.11 Default-Language: Haskell2010 Executable DynamoDb Main-is: DynamoDb.hs Hs-source-dirs: Examples if !flag(Examples) Buildable: False else Buildable: True Build-depends: aws, base == 4.*, data-default, exceptions, http-conduit, text, conduit Default-Language: Haskell2010 Executable Sqs Main-is: Sqs.hs Hs-source-dirs: Examples if !flag(Examples) Buildable: False else Buildable: True Build-depends: base == 4.*, aws, errors >= 2.0, text >=0.11, transformers >= 0.3 Default-Language: Haskell2010 test-suite sqs-tests type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: tests main-is: Sqs/Main.hs other-modules: Utils build-depends: QuickCheck >= 2.7, aeson >= 0.7, aws, base == 4.*, bytestring >= 0.10, errors >= 2.0, http-client >= 0.3, lifted-base >= 0.2, monad-control >= 0.3, mtl >= 2.1, quickcheck-instances >= 0.3, resourcet >= 1.1, tagged >= 0.7, tasty >= 0.8, tasty-quickcheck >= 0.8, text >= 1.1, time, transformers >= 0.3, transformers-base >= 0.4 ghc-options: -Wall -threaded test-suite dynamodb-tests type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: tests main-is: DynamoDb/Main.hs other-modules: Utils DynamoDb.Utils build-depends: QuickCheck >= 2.7, aeson >= 0.7, aws, base == 4.*, bytestring >= 0.10, errors >= 2.0, http-client >= 0.3, lifted-base >= 0.2, monad-control >= 0.3, mtl >= 2.1, quickcheck-instances >= 0.3, resourcet >= 1.1, tagged >= 0.7, tasty >= 0.8, tasty-quickcheck >= 0.8, text >= 1.1, time, transformers >= 0.3, transformers-base >= 0.4 aws-0.13.0/Aws.hs0000644000000000000000000000233112615132266011644 0ustar0000000000000000module Aws ( -- * Logging LogLevel(..) , Logger , defaultLog -- * Configuration , Configuration(..) , baseConfiguration , dbgConfiguration -- * Transaction runners -- ** Safe runners , aws , awsRef , pureAws , simpleAws -- ** Unsafe runners , unsafeAws , unsafeAwsRef -- ** URI runners , awsUri -- ** Iterated runners --, awsIteratedAll , awsIteratedSource , awsIteratedList -- * Response -- ** Full HTTP response , HTTPResponseConsumer -- ** Metadata in responses , Response(..) , readResponse , readResponseIO , ResponseMetadata -- ** Memory responses , AsMemoryResponse(..) -- ** Exception types , XmlException(..) , HeaderException(..) , FormException(..) -- * Query -- ** Service configuration , ServiceConfiguration , DefaultServiceConfiguration(..) , NormalQuery , UriOnlyQuery -- ** Expiration , TimeInfo(..) -- * Transactions , Transaction , IteratedTransaction -- * Credentials , Credentials(..) , makeCredentials , credentialsDefaultFile , credentialsDefaultKey , loadCredentialsFromFile , loadCredentialsFromEnv , loadCredentialsFromInstanceMetadata , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault ) where import Aws.Aws import Aws.Core aws-0.13.0/README.org0000644000000000000000000001251412615132266012230 0ustar0000000000000000#+TITLE: Amazon Web Services for Haskell * Introduction The ~aws~ package attempts to provide support for using Amazon Web Services like S3 (storage), SQS (queuing) and others to Haskell programmers. The ultimate goal is to support all Amazon Web Services. * Installation Make sure you have a recent GHC installed, as well as cabal-install, and installation should be as easy as: #+BEGIN_SRC bash $ cabal install aws #+END_SRC If you prefer to install from source yourself, you should first get a clone of the ~aws~ repository, and install it from inside the source directory: #+BEGIN_SRC bash $ git clone https://github.com/aristidb/aws.git $ cd aws $ cabal install #+END_SRC * Using aws ** Concepts and organisation The aws package is organised into the general =Aws= module namespace, and subnamespaces like =Aws.S3= for each Amazon Web Service. Under each service namespace in turn, there are general support modules and and =Aws..Commands.= module for each command. For easier usage, there are the "bundling" modules =Aws= (general support), and =Aws.=. The primary concept in aws is the /Transaction/, which corresponds to a single HTTP request to the Amazon Web Services. A transaction consists of a request and a response, which are associated together via the =Transaction= typeclass. Requests and responses are simple Haskell records, but for some requests there are convenience functions to fill in default values for many parameters. ** Example usage To be able to access AWS resources, you should put your into a configuration file. (You don't have to store it in a file, but that's how we do it in this example.) Save the following in ~$HOME/.aws-keys~. #+BEGIN_EXAMPLE default AccessKeyID SecretKey #+END_EXAMPLE You do have to replace AccessKeyID and SecretKey with the Access Key ID and the Secret Key respectively, of course. Then, copy this example into a Haskell file, and run it with ~runghc~ (after installing aws): #+BEGIN_SRC haskell {-# LANGUAGE OverloadedStrings #-} import qualified Aws import qualified Aws.S3 as S3 import Data.Conduit (($$+-)) import Data.Conduit.Binary (sinkFile) import Network.HTTP.Conduit (withManager, responseBody) main :: IO () main = do {- Set up AWS credentials and the default configuration. -} cfg <- Aws.baseConfiguration let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery {- Set up a ResourceT region with an available HTTP manager. -} withManager $ \mgr -> do {- Create a request object with S3.getObject and run the request with pureAws. -} S3.GetObjectResponse { S3.gorResponse = rsp } <- Aws.pureAws cfg s3cfg mgr $ S3.getObject "haskell-aws" "cloud-remote.pdf" {- Save the response to a file. -} responseBody rsp $$+- sinkFile "cloud-remote.pdf" #+END_SRC You can also find this example in the source distribution in the ~Examples/~ folder. * Frequently Asked Questions ** S3 questions - I get an error when I try to access my bucket with upper-case characters / a very long name. Those names are not compliant with DNS. You need to use path-style requests, by setting ~s3RequestStyle~ in the configuration to ~PathStyle~. Note that such bucket names are only allowed in the US standard region, so your endpoint needs to be US standard. * Release Notes See CHANGELOG * Resources - [[https://github.com/aristidb/aws][aws on Github]] - [[http://hackage.haskell.org/package/aws][aws on Hackage]] (includes reference documentation) - [[http://aws.amazon.com/][Official Amazon Web Services website]] * Contributors | Name | Github | E-Mail | Company | Components | |--------------------+--------------+---------------------------+------------------------+---------------| | Abhinav Gupta | [[https://github.com/abhinav][abhinav]] | mail@abhinavg.net | - | IAM, SES | | Aristid Breitkreuz | [[https://github.com/aristidb][aristidb]] | aristidb@gmail.com | - | Co-Maintainer | | Bas van Dijk | [[https://github.com/basvandijk][basvandijk]] | v.dijk.bas@gmail.com | [[http://erudify.ch][Erudify AG]] | S3 | | David Vollbracht | [[https://github.com/qxjit][qxjit]] | | | | | Felipe Lessa | [[https://github.com/meteficha][meteficha]] | felipe.lessa@gmail.com | currently secret | Core, S3, SES | | Nathan Howell | [[https://github.com/NathanHowell][NathanHowell]] | nhowell@alphaheavy.com | [[http://www.alphaheavy.com][Alpha Heavy Industries]] | S3 | | Ozgun Ataman | [[https://github.com/ozataman][ozataman]] | ozgun.ataman@soostone.com | [[http://soostone.com][Soostone Inc]] | Core, S3, DynamoDb | | Steve Severance | [[https://github.com/sseveran][sseveran]] | sseverance@alphaheavy.com | [[http://www.alphaheavy.com][Alpha Heavy Industries]] | S3, SQS | | John Wiegley | [[https://github.com/jwiegley][jwiegley]] | johnw@fpcomplete.com | [[http://fpcomplete.com][FP Complete]] | Co-Maintainer, S3 | | Chris Dornan | [[https://github.com/cdornan][cdornan]] | chris.dornan@irisconnect.co.uk | [[http://irisconnect.co.uk][Iris Connect]] | Core | | John Lenz | [[https://github/com/wuzzeb][wuzzeb]] | | | DynamoDB, Core | aws-0.13.0/Setup.hs0000644000000000000000000000005612615132266012214 0ustar0000000000000000import Distribution.Simple main = defaultMain aws-0.13.0/Examples/0000755000000000000000000000000012615132266012335 5ustar0000000000000000aws-0.13.0/Examples/NukeBucket.hs0000644000000000000000000000242712615132266014736 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} import qualified Aws import qualified Aws.S3 as S3 import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Data.Text (pack) import Control.Monad ((<=<)) import Control.Monad.IO.Class (liftIO) import Network.HTTP.Conduit (withManager, responseBody) import System.Environment (getArgs) main :: IO () main = do [bucket] <- fmap (map pack) getArgs {- Set up AWS credentials and the default configuration. -} cfg <- Aws.baseConfiguration let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery {- Set up a ResourceT region with an available HTTP manager. -} withManager $ \mgr -> do let src = Aws.awsIteratedSource cfg s3cfg mgr (S3.getBucket bucket) let deleteObjects [] = return () deleteObjects os = do let keys = map S3.objectKey os liftIO $ putStrLn ("Deleting objects: " ++ show keys) _ <- Aws.pureAws cfg s3cfg mgr (S3.deleteObjects bucket (map S3.objectKey os)) return () src C.$$ CL.mapM_ (deleteObjects . S3.gbrContents <=< Aws.readResponseIO) liftIO $ putStrLn ("Deleting bucket: " ++ show bucket) _ <- Aws.pureAws cfg s3cfg mgr (S3.DeleteBucket bucket) return () aws-0.13.0/Examples/SimpleDb.hs0000644000000000000000000000105212615132266014366 0ustar0000000000000000import qualified Aws import qualified Aws.SimpleDb as Sdb import qualified Data.Text as T import qualified Data.Text.IO as T main :: IO () main = do {- Load configuration -} cfg <- Aws.baseConfiguration let sdbCfg = Aws.defServiceConfig putStrLn "Making request..." {- Make request -} let req = Sdb.listDomains { Sdb.ldMaxNumberOfDomains = Just 10 } Sdb.ListDomainsResponse names _token <- Aws.simpleAws cfg sdbCfg req {- Analyze response -} putStrLn "First 10 domains:" mapM_ (T.putStrLn . T.cons '\t') names aws-0.13.0/Examples/GetObject.hs0000644000000000000000000000151612615132266014542 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} import qualified Aws import qualified Aws.S3 as S3 import Data.Conduit (($$+-)) import Data.Conduit.Binary (sinkFile) import Network.HTTP.Conduit (withManager, responseBody) main :: IO () main = do {- Set up AWS credentials and the default configuration. -} cfg <- Aws.baseConfiguration let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery {- Set up a ResourceT region with an available HTTP manager. -} withManager $ \mgr -> do {- Create a request object with S3.getObject and run the request with pureAws. -} S3.GetObjectResponse { S3.gorResponse = rsp } <- Aws.pureAws cfg s3cfg mgr $ S3.getObject "haskell-aws" "cloud-remote.pdf" {- Save the response to a file. -} responseBody rsp $$+- sinkFile "cloud-remote.pdf" aws-0.13.0/Examples/DynamoDb.hs0000644000000000000000000000774012615132266014376 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} module Main where ------------------------------------------------------------------------------- import Aws import Aws.DynamoDb.Commands import Aws.DynamoDb.Core import Control.Concurrent import Control.Monad import Control.Monad.Catch import Control.Applicative import Data.Conduit import Data.Maybe import qualified Data.Conduit.List as C import qualified Data.Text as T import Network.HTTP.Conduit (withManager) ------------------------------------------------------------------------------- createTableAndWait :: IO () createTableAndWait = do let req0 = createTable "devel-1" [AttributeDefinition "name" AttrString] (HashOnly "name") (ProvisionedThroughput 1 1) resp0 <- runCommand req0 print resp0 print "Waiting for table to be created" threadDelay (30 * 1000000) let req1 = DescribeTable "devel-1" resp1 <- runCommand req1 print resp1 data ExampleItem = ExampleItem { name :: T.Text , class_ :: T.Text , boolAttr :: Bool , oldBoolAttr :: Bool } deriving (Show) instance ToDynItem ExampleItem where toItem (ExampleItem name class_ boolAttr oldBoolAttr) = item [ attr "name" name , attr "class" class_ , attr "boolattr" boolAttr , attr "oldboolattr" (OldBool oldBoolAttr) ] instance FromDynItem ExampleItem where parseItem x = ExampleItem <$> getAttr "name" x <*> getAttr "class" x <*> getAttr "boolattr" x <*> getAttr "oldboolattr" x main :: IO () main = do cfg <- Aws.baseConfiguration createTableAndWait `catch` (\DdbError{} -> putStrLn "Table already exists") putStrLn "Putting an item..." let x = ExampleItem { name = "josh", class_ = "not-so-awesome", boolAttr = False, oldBoolAttr = True } let req1 = (putItem "devel-1" (toItem x)) { piReturn = URAllOld , piRetCons = RCTotal , piRetMet = RICMSize } resp1 <- runCommand req1 print resp1 putStrLn "Getting the item back..." let req2 = getItem "devel-1" (hk "name" "josh") resp2 <- runCommand req2 print resp2 let y = fromItem (fromMaybe (item []) $ girItem resp2) :: Either String ExampleItem print y print =<< runCommand (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesome")]) echo "Updating with false conditional." (print =<< runCommand (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer")]) { uiExpect = Conditions CondAnd [Condition "name" (DEq "john")] }) `catch` (\ (e :: DdbError) -> echo ("Eating exception: " ++ show e)) echo "Getting the item back..." print =<< runCommand req2 echo "Updating with true conditional" print =<< runCommand (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer"), au (attr "oldboolattr" False)]) { uiExpect = Conditions CondAnd [Condition "name" (DEq "josh")] } echo "Getting the item back..." print =<< runCommand req2 echo "Running a Query command..." print =<< runCommand (query "devel-1" (Slice (Attribute "name" "josh") Nothing)) echo "Running a Scan command..." print =<< runCommand (scan "devel-1") echo "Filling table with several items..." forM_ [0..30] $ \ i -> do threadDelay 50000 runCommand $ putItem "devel-1" $ item [Attribute "name" (toValue $ T.pack ("lots-" ++ show i)), attrAs int "val" i] echo "Now paginating in increments of 5..." let q0 = (scan "devel-1") { sLimit = Just 5 } xs <- withManager $ \mgr -> do awsIteratedList cfg debugServiceConfig mgr q0 $$ C.consume echo ("Pagination returned " ++ show (length xs) ++ " items") runCommand r = do cfg <- Aws.baseConfiguration Aws.simpleAws cfg debugServiceConfig r echo = putStrLn aws-0.13.0/Examples/PutBucketNearLine.hs0000644000000000000000000000227712615132266016225 0ustar0000000000000000-- | Example of creating a Nearline bucket on Google Cloud Storage. {-# LANGUAGE OverloadedStrings #-} import qualified Aws import qualified Aws.Core as Aws import qualified Aws.S3 as S3 import Data.Conduit (($$+-)) import Data.Conduit.Binary (sinkFile) import Network.HTTP.Conduit (withManager, RequestBody(..)) import Control.Monad.IO.Class import Control.Concurrent import System.IO import Control.Applicative import qualified Data.Text as T import System.Environment sc :: S3.StorageClass sc = S3.OtherStorageClass (T.pack "NEARLINE") main :: IO () main = do [bucket] <- fmap (map T.pack) getArgs {- Set up AWS credentials and S3 configuration using the Google Cloud - Storage endpoint. -} Just creds <- Aws.loadCredentialsFromEnv let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) let s3cfg = S3.s3 Aws.HTTP "storage.googleapis.com" False {- Set up a ResourceT region with an available HTTP manager. -} withManager $ \mgr -> do {- Create a request object with S3.PutBucket and run the request with pureAws. -} rsp <- Aws.pureAws cfg s3cfg mgr $ S3.PutBucket bucket Nothing "US" (Just sc) liftIO $ print rsp aws-0.13.0/Examples/MultipartTransfer.hs0000644000000000000000000000310412615132266016355 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {- This example demonstrates an ability to stream in constant space content from a remote resource into an S3 object accessible publicly -} import qualified Aws import Aws.Aws (Configuration (..)) import qualified Aws.S3 as S3 import Control.Applicative ((<$>)) import Data.Conduit (unwrapResumable) import qualified Data.Text as T import Network.HTTP.Conduit (http, parseUrl, responseBody, withManager) import System.Environment (getArgs) main :: IO () main = do maybeCreds <- Aws.loadCredentialsFromEnv case maybeCreds of Nothing -> do putStrLn "Please set the environment variables AWS_ACCESS_KEY_ID and AWS_ACCESS_KEY_SECRET" Just creds -> do args <- getArgs cfg <- Aws.dbgConfiguration let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery case args of [sourceUrl,destBucket,destObj] -> do request <- parseUrl sourceUrl withManager $ \mgr -> do resumableSource <- responseBody <$> http request mgr (source, _) <- unwrapResumable resumableSource let initiator b o = (S3.postInitiateMultipartUpload b o){S3.imuAcl = Just S3.AclPublicRead} S3.multipartUploadWithInitiator cfg{credentials = creds} s3cfg initiator mgr (T.pack destBucket) (T.pack destObj) source (10*1024*1024) _ -> do putStrLn "Usage: MultipartTransfer sourceUrl destinationBucket destinationObjectname" aws-0.13.0/Examples/MultipartUpload.hs0000644000000000000000000000204612615132266016021 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} import qualified Aws import qualified Aws.S3 as S3 import Data.Conduit (($$)) import Data.Conduit.Binary (sourceFile) import qualified Data.Text as T import Network.HTTP.Conduit (withManager, responseBody) import Control.Monad.Trans.Resource (ResourceT) import System.Environment (getArgs) main :: IO () main = do {- Set up AWS credentials and the default configuration. -} cfg <- Aws.dbgConfiguration let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery args <- getArgs let doUpload bucket obj file chunkSize = withManager $ \mgr -> do (sourceFile file $$ S3.multipartUploadSink cfg s3cfg mgr (T.pack bucket) (T.pack obj) (chunkSize*1024*1024)) :: ResourceT IO () case args of [bucket,obj,file] -> doUpload bucket obj file 10 [bucket,obj,file,chunkSize] -> doUpload bucket obj file (read chunkSize) _ -> do putStrLn "Usage: MultipartUpload bucket objectname filename (chunksize(MB)::optinal)" aws-0.13.0/Examples/Sqs.hs0000644000000000000000000001161312615132266013441 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} import qualified Aws import qualified Aws.Core import qualified Aws.Sqs as Sqs import Control.Concurrent import Control.Error import Control.Monad.IO.Class import Data.Monoid import Data.String import qualified Data.Text.IO as T import qualified Data.Text as T import qualified Data.Text.Read as TR import Control.Monad (forM_, forM, replicateM) {-| Created by Tim Perry on September 18, 2013 | | All code relies on a correctly configured ~/.aws-keys and will access that account which | may incur charges for the user! | | This code will demonstrate: | - Listing all queue's attached to the current AWS account. | - Creating a queue | - Adding messages to the queue | - Retrieving messages from the queue | - Deleting messages from the queue | and finally | - Deleting the queue. | -} main :: IO () main = do {- Set up AWS credentials and the default configuration. -} cfg <- Aws.baseConfiguration let sqscfg = Sqs.sqs Aws.Core.HTTP Sqs.sqsEndpointUsWest2 False :: Sqs.SqsConfiguration Aws.NormalQuery {- List any Queues you have already created in your SQS account -} Sqs.ListQueuesResponse qUrls <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing let origQUrlCount = length qUrls putStrLn $ "originally had " ++ show origQUrlCount ++ " queue urls" mapM_ print qUrls {- Create a request object to create a queue and then print out the Queue URL -} let qName = "scaledsoftwaretest1" let createQReq = Sqs.CreateQueue (Just 8400) qName Sqs.CreateQueueResponse qUrl <- Aws.simpleAws cfg sqscfg createQReq T.putStrLn $ T.concat ["queue was created with Url: ", qUrl] {- Create a QueueName object, sqsQName, to hold the name of this queue for the duration -} let awsAccountNum = T.split (== '/') qUrl !! 3 let sqsQName = Sqs.QueueName qName awsAccountNum {- list queue attributes -- for this example we will only list the approximateNumberOfMessages in this queue. -} let qAttReq = Sqs.GetQueueAttributes sqsQName [Sqs.ApproximateNumberOfMessages] Sqs.GetQueueAttributesResponse attPairs <- Aws.simpleAws cfg sqscfg qAttReq mapM_ (\(attName, attText) -> T.putStrLn $ T.concat [" ", Sqs.printQueueAttribute attName, " ", attText]) attPairs {- Here we add some messages to the queue -} let messages = map (\n -> T.pack $ "msg" ++ show n) [1 .. 10] {- Add messages to the queue -} forM_ messages $ \mText -> do T.putStrLn $ " Adding: " <> mText let sqsSendMessage = Sqs.SendMessage mText sqsQName [] (Just 0) Sqs.SendMessageResponse _ mid _ <- Aws.simpleAws cfg sqscfg sqsSendMessage T.putStrLn $ " message id: " <> sshow mid {- Here we remove messages from the queue one at a time. -} let receiveMessageReq = Sqs.ReceiveMessage Nothing [] (Just 1) [] sqsQName (Just 20) let numMessages = length messages removedMsgs <- replicateM numMessages $ do msgs <- exceptT (const $ return []) return . retryT 2 $ do Sqs.ReceiveMessageResponse r <- liftIO $ Aws.simpleAws cfg sqscfg receiveMessageReq case r of [] -> throwE "no message received" _ -> return r putStrLn $ "number of messages received: " ++ show (length msgs) forM msgs (\msg -> do -- here we remove a message, delete it from the queue, and then return the -- text sent in the body of the message putStrLn $ " Received " ++ show (Sqs.mBody msg) Aws.simpleAws cfg sqscfg $ Sqs.DeleteMessage (Sqs.mReceiptHandle msg) sqsQName return $ Sqs.mBody msg) {- Now we'll delete the queue we created at the start of this program -} putStrLn $ "Deleting the queue: " ++ show (Sqs.qName sqsQName) let dQReq = Sqs.DeleteQueue sqsQName _ <- Aws.simpleAws cfg sqscfg dQReq {- | Let's make sure the queue was actually deleted and that the same number of queues exist at when | the program ends as when it started. -} exceptT T.putStrLn T.putStrLn . retryT 4 $ do qUrls <- liftIO $ do putStrLn $ "Listing all queueus to check to see if " ++ show (Sqs.qName sqsQName) ++ " is gone" Sqs.ListQueuesResponse qUrls_ <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing mapM_ T.putStrLn qUrls_ return qUrls_ if qUrl `elem` qUrls then throwE $ " *\n *\n * Warning, '" <> sshow qName <> "' was not deleted\n" <> " * This is probably just a race condition." else return $ " The queue '" <> sshow qName <> "' was correctly deleted" retryT :: MonadIO m => Int -> ExceptT T.Text m a -> ExceptT T.Text m a retryT i f = go 1 where go x | x >= i = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) f | otherwise = f `catchE` \_ -> do liftIO $ threadDelay (1000000 * min 60 (2^(x-1))) go (succ x) sshow :: (Show a, IsString b) => a -> b sshow = fromString . show aws-0.13.0/Aws/0000755000000000000000000000000012615132266011311 5ustar0000000000000000aws-0.13.0/Aws/Iam.hs0000644000000000000000000000022412615132266012351 0ustar0000000000000000module Aws.Iam ( module Aws.Iam.Commands , module Aws.Iam.Core ) where import Aws.Iam.Commands import Aws.Iam.Core aws-0.13.0/Aws/SimpleDb.hs0000644000000000000000000000021712615132266013344 0ustar0000000000000000module Aws.SimpleDb ( module Aws.SimpleDb.Commands , module Aws.SimpleDb.Core ) where import Aws.SimpleDb.Commands import Aws.SimpleDb.Core aws-0.13.0/Aws/Aws.hs0000644000000000000000000003041712615132266012404 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE BangPatterns #-} module Aws.Aws ( -- * Logging LogLevel(..) , Logger , defaultLog -- * Configuration , Configuration(..) , baseConfiguration , dbgConfiguration -- * Transaction runners -- ** Safe runners , aws , awsRef , pureAws , memoryAws , simpleAws -- ** Unsafe runners , unsafeAws , unsafeAwsRef -- ** URI runners , awsUri -- * Iterated runners --, awsIteratedAll , awsIteratedSource , awsIteratedSource' , awsIteratedList , awsIteratedList' ) where import Aws.Core import Control.Applicative import qualified Control.Exception.Lifted as E import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans import Control.Monad.Trans.Resource import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.CaseInsensitive as CI import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Data.IORef import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Network.HTTP.Conduit as HTTP import System.IO (stderr) -- | The severity of a log message, in rising order. data LogLevel = Debug | Info | Warning | Error deriving (Show, Eq, Ord) -- | The interface for any logging function. Takes log level and a log message, and can perform an arbitrary -- IO action. type Logger = LogLevel -> T.Text -> IO () -- | The default logger @defaultLog minLevel@, which prints log messages above level @minLevel@ to @stderr@. defaultLog :: LogLevel -> Logger defaultLog minLevel lev t | lev >= minLevel = T.hPutStrLn stderr $ T.concat [T.pack $ show lev, ": ", t] | otherwise = return () -- | The configuration for an AWS request. You can use multiple configurations in parallel, even over the same HTTP -- connection manager. data Configuration = Configuration { -- | Whether to restrict the signature validity with a plain timestamp, or with explicit expiration -- (absolute or relative). timeInfo :: TimeInfo -- | AWS access credentials. , credentials :: Credentials -- | The error / message logger. , logger :: Logger } -- | The default configuration, with credentials loaded from environment variable or configuration file -- (see 'loadCredentialsDefault'). baseConfiguration :: MonadIO io => io Configuration baseConfiguration = liftIO $ do cr <- loadCredentialsDefault case cr of Nothing -> E.throw $ NoCredentialsException "could not locate aws credentials" Just cr' -> return Configuration { timeInfo = Timestamp , credentials = cr' , logger = defaultLog Warning } -- | Debug configuration, which logs much more verbosely. dbgConfiguration :: MonadIO io => io Configuration dbgConfiguration = do c <- baseConfiguration return c { logger = defaultLog Debug } -- | Run an AWS transaction, with HTTP manager and metadata wrapped in a 'Response'. -- -- All errors are caught and wrapped in the 'Response' value. -- -- Metadata is logged at level 'Info'. -- -- Usage (with existing 'HTTP.Manager'): -- @ -- resp <- aws cfg serviceCfg manager request -- @ aws :: (Transaction r a) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> ResourceT IO (Response (ResponseMetadata a) a) aws = unsafeAws -- | Run an AWS transaction, with HTTP manager and metadata returned in an 'IORef'. -- -- Errors are not caught, and need to be handled with exception handlers. -- -- Metadata is not logged. -- -- Usage (with existing 'HTTP.Manager'): -- @ -- ref <- newIORef mempty; -- resp <- awsRef cfg serviceCfg manager request -- @ -- Unfortunately, the ";" above seems necessary, as haddock does not want to split lines for me. awsRef :: (Transaction r a) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> IORef (ResponseMetadata a) -> r -> ResourceT IO a awsRef = unsafeAwsRef -- | Run an AWS transaction, with HTTP manager and without metadata. -- -- Metadata is logged at level 'Info'. -- -- Usage (with existing 'HTTP.Manager'): -- @ -- resp <- aws cfg serviceCfg manager request -- @ pureAws :: (Transaction r a) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> ResourceT IO a pureAws cfg scfg mgr req = readResponseIO =<< aws cfg scfg mgr req -- | Run an AWS transaction, with HTTP manager and without metadata. -- -- Metadata is logged at level 'Info'. -- -- Usage (with existing 'HTTP.Manager'): -- @ -- resp <- aws cfg serviceCfg manager request -- @ memoryAws :: (Transaction r a, AsMemoryResponse a, MonadIO io) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> io (MemoryResponse a) memoryAws cfg scfg mgr req = liftIO $ runResourceT $ loadToMemory =<< readResponseIO =<< aws cfg scfg mgr req -- | Run an AWS transaction, /without/ HTTP manager and without metadata. -- -- Metadata is logged at level 'Info'. -- -- Note that this is potentially less efficient than using 'aws', because HTTP connections cannot be re-used. -- -- Usage: -- @ -- resp <- simpleAws cfg serviceCfg request -- @ simpleAws :: (Transaction r a, AsMemoryResponse a, MonadIO io) => Configuration -> ServiceConfiguration r NormalQuery -> r -> io (MemoryResponse a) simpleAws cfg scfg request = liftIO $ HTTP.withManager $ \manager -> loadToMemory =<< readResponseIO =<< aws cfg scfg manager request -- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair. -- -- This is especially useful for debugging and development, you should not have to use it in production. -- -- All errors are caught and wrapped in the 'Response' value. -- -- Metadata is wrapped in the Response, and also logged at level 'Info'. unsafeAws :: (ResponseConsumer r a, Monoid (ResponseMetadata a), Loggable (ResponseMetadata a), SignQuery r) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> ResourceT IO (Response (ResponseMetadata a) a) unsafeAws cfg scfg manager request = do metadataRef <- liftIO $ newIORef mempty let catchAll :: ResourceT IO a -> ResourceT IO (Either E.SomeException a) catchAll = E.handle (return . Left) . fmap Right resp <- catchAll $ unsafeAwsRef cfg scfg manager metadataRef request metadata <- liftIO $ readIORef metadataRef liftIO $ logger cfg Info $ "Response metadata: " `mappend` toLogText metadata return $ Response metadata resp -- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair. -- -- This is especially useful for debugging and development, you should not have to use it in production. -- -- Errors are not caught, and need to be handled with exception handlers. -- -- Metadata is put in the 'IORef', but not logged. unsafeAwsRef :: (ResponseConsumer r a, Monoid (ResponseMetadata a), SignQuery r) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> IORef (ResponseMetadata a) -> r -> ResourceT IO a unsafeAwsRef cfg info manager metadataRef request = do sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg let !q = {-# SCC "unsafeAwsRef:signQuery" #-} signQuery request info sd let logDebug = liftIO . logger cfg Debug . T.pack logDebug $ "String to sign: " ++ show (sqStringToSign q) !httpRequest <- {-# SCC "unsafeAwsRef:httpRequest" #-} liftIO $ queryToHttpRequest q logDebug $ "Host: " ++ show (HTTP.host httpRequest) logDebug $ "Path: " ++ show (HTTP.path httpRequest) logDebug $ "Query string: " ++ show (HTTP.queryString httpRequest) case HTTP.requestBody httpRequest of HTTP.RequestBodyLBS lbs -> logDebug $ "Body: " ++ show (L.take 1000 lbs) HTTP.RequestBodyBS bs -> logDebug $ "Body: " ++ show (B.take 1000 bs) _ -> return () hresp <- {-# SCC "unsafeAwsRef:http" #-} HTTP.http httpRequest manager logDebug $ "Response status: " ++ show (HTTP.responseStatus hresp) forM_ (HTTP.responseHeaders hresp) $ \(hname,hvalue) -> liftIO $ logger cfg Debug $ T.decodeUtf8 $ "Response header '" `mappend` CI.original hname `mappend` "': '" `mappend` hvalue `mappend` "'" {-# SCC "unsafeAwsRef:responseConsumer" #-} responseConsumer request metadataRef hresp -- | Run a URI-only AWS transaction. Returns a URI that can be sent anywhere. Does not work with all requests. -- -- Usage: -- @ -- uri <- awsUri cfg request -- @ awsUri :: (SignQuery request, MonadIO io) => Configuration -> ServiceConfiguration request UriOnlyQuery -> request -> io B.ByteString awsUri cfg info request = liftIO $ do let ti = timeInfo cfg cr = credentials cfg sd <- signatureData ti cr let q = signQuery request info sd logger cfg Debug $ T.pack $ "String to sign: " ++ show (sqStringToSign q) return $ queryToUri q {- -- | Run an iterated AWS transaction. May make multiple HTTP requests. awsIteratedAll :: (IteratedTransaction r a) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> ResourceT IO (Response [ResponseMetadata a] a) awsIteratedAll cfg scfg manager req_ = go req_ Nothing where go request prevResp = do Response meta respAttempt <- aws cfg scfg manager request case maybeCombineIteratedResponse prevResp <$> respAttempt of f@(Failure _) -> return (Response [meta] f) s@(Success resp) -> case nextIteratedRequest request resp of Nothing -> return (Response [meta] s) Just nextRequest -> mapMetadata (meta:) `liftM` go nextRequest (Just resp) -} awsIteratedSource :: (IteratedTransaction r a) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> C.Producer (ResourceT IO) (Response (ResponseMetadata a) a) awsIteratedSource cfg scfg manager req_ = awsIteratedSource' run req_ where run r = do res <- aws cfg scfg manager r a <- readResponseIO res return (a, res) awsIteratedList :: (IteratedTransaction r a, ListResponse a i) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> C.Producer (ResourceT IO) i awsIteratedList cfg scfg manager req = awsIteratedList' run req where run r = readResponseIO =<< aws cfg scfg manager r ------------------------------------------------------------------------------- -- | A more flexible version of 'awsIteratedSource' that uses a -- user-supplied run function. Useful for embedding AWS functionality -- within application specific monadic contexts. awsIteratedSource' :: (Monad m, IteratedTransaction r a) => (r -> m (a, b)) -- ^ A runner function for executing transactions. -> r -- ^ An initial request -> C.Producer m b awsIteratedSource' run r0 = go r0 where go q = do (a, b) <- lift $ run q C.yield b case nextIteratedRequest q a of Nothing -> return () Just q' -> go q' ------------------------------------------------------------------------------- -- | A more flexible version of 'awsIteratedList' that uses a -- user-supplied run function. Useful for embedding AWS functionality -- within application specific monadic contexts. awsIteratedList' :: (Monad m, IteratedTransaction r b, ListResponse b c) => (r -> m b) -- ^ A runner function for executing transactions. -> r -- ^ An initial request -> C.Producer m c awsIteratedList' run r0 = awsIteratedSource' run' r0 C.=$= CL.concatMap listResponse where dupl a = (a,a) run' r = dupl `liftM` run r aws-0.13.0/Aws/DynamoDb.hs0000644000000000000000000000125012615132266013340 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Aws.DynaboDb -- Copyright : Ozgun Ataman, Soostone Inc. -- License : BSD3 -- -- Maintainer : Ozgun Ataman -- Stability : experimental -- ---------------------------------------------------------------------------- module Aws.DynamoDb ( module Aws.DynamoDb.Core , module Aws.DynamoDb.Commands ) where ------------------------------------------------------------------------------- import Aws.DynamoDb.Commands import Aws.DynamoDb.Core ------------------------------------------------------------------------------- aws-0.13.0/Aws/Core.hs0000644000000000000000000007707312615132266012553 0ustar0000000000000000{-# LANGUAGE CPP #-} module Aws.Core ( -- * Logging Loggable(..) -- * Response -- ** Metadata in responses , Response(..) , readResponse , readResponseIO , tellMetadata , tellMetadataRef , mapMetadata -- ** Response data consumers , HTTPResponseConsumer , ResponseConsumer(..) -- ** Memory response , AsMemoryResponse(..) -- ** List response , ListResponse(..) -- ** Exception types , XmlException(..) , HeaderException(..) , FormException(..) , NoCredentialsException(..) -- ** Response deconstruction helpers , readHex2 -- *** XML , elContent , elCont , force , forceM , textReadInt , readInt , xmlCursorConsumer -- * Query , SignedQuery(..) , NormalQuery , UriOnlyQuery , queryToHttpRequest , queryToUri -- ** Expiration , TimeInfo(..) , AbsoluteTimeInfo(..) , fromAbsoluteTimeInfo , makeAbsoluteTimeInfo -- ** Signature , SignatureData(..) , signatureData , SignQuery(..) , AuthorizationHash(..) , amzHash , signature , authorizationV4 -- ** Query construction helpers , queryList , awsBool , awsTrue , awsFalse , fmtTime , fmtRfc822Time , rfc822Time , fmtAmzTime , fmtTimeEpochSeconds , parseHttpDate , httpDate1 , textHttpDate , iso8601UtcDate -- * Transactions , Transaction , IteratedTransaction(..) -- * Credentials , Credentials(..) , makeCredentials , credentialsDefaultFile , credentialsDefaultKey , loadCredentialsFromFile , loadCredentialsFromEnv , loadCredentialsFromInstanceMetadata , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault -- * Service configuration , DefaultServiceConfiguration(..) -- * HTTP types , Protocol(..) , defaultPort , Method(..) , httpMethod ) where import Aws.Ec2.InstanceMetadata import Aws.Network import qualified Blaze.ByteString.Builder as Blaze import Control.Applicative import Control.Arrow import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM)) import Crypto.Hash import qualified Data.Aeson as A import Data.Byteable import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as BU import Data.Char import Data.Conduit (($$+-)) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Data.Default (def) import Data.IORef import Data.List import qualified Data.Map as M import Data.Maybe import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time import qualified Data.Traversable as Traversable import Data.Typeable import Data.Word import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import System.Directory import System.Environment import System.FilePath (()) #if MIN_VERSION_time(1,5,0) import Data.Time.Format #else import System.Locale #endif import qualified Text.XML as XML import qualified Text.XML.Cursor as Cu import Text.XML.Cursor hiding (force, forceM) ------------------------------------------------------------------------------- -- | Types that can be logged (textually). class Loggable a where toLogText :: a -> T.Text -- | A response with metadata. Can also contain an error response, or -- an internal error, via 'Attempt'. -- -- Response forms a Writer-like monad. data Response m a = Response { responseMetadata :: m , responseResult :: Either E.SomeException a } deriving (Show, Functor) -- | Read a response result (if it's a success response, fail otherwise). readResponse :: MonadThrow n => Response m a -> n a readResponse = either throwM return . responseResult -- | Read a response result (if it's a success response, fail otherwise). In MonadIO. readResponseIO :: MonadIO io => Response m a -> io a readResponseIO = liftIO . readResponse -- | An empty response with some metadata. tellMetadata :: m -> Response m () tellMetadata m = Response m (return ()) -- | Apply a function to the metadata. mapMetadata :: (m -> n) -> Response m a -> Response n a mapMetadata f (Response m a) = Response (f m) a --multiResponse :: Monoid m => Response m a -> Response [m] a -> instance Monoid m => Applicative (Response m) where pure x = Response mempty (Right x) (<*>) = ap instance Monoid m => Monad (Response m) where return x = Response mempty (Right x) Response m1 (Left e) >>= _ = Response m1 (Left e) Response m1 (Right x) >>= f = let Response m2 y = f x in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too instance Monoid m => MonadThrow (Response m) where throwM e = Response mempty (throwM e) -- | Add metadata to an 'IORef' (using 'mappend'). tellMetadataRef :: Monoid m => IORef m -> m -> IO () tellMetadataRef r m = modifyIORef r (`mappend` m) -- | A full HTTP response parser. Takes HTTP status, response headers, and response body. type HTTPResponseConsumer a = HTTP.Response (C.ResumableSource (ResourceT IO) ByteString) -> ResourceT IO a -- | Class for types that AWS HTTP responses can be parsed into. -- -- The request is also passed for possibly required additional metadata. -- -- Note that for debugging, there is an instance for 'L.ByteString'. class Monoid (ResponseMetadata resp) => ResponseConsumer req resp where -- | Metadata associated with a response. Typically there is one -- metadata type for each AWS service. type ResponseMetadata resp -- | Response parser. Takes the corresponding request, an 'IORef' -- for metadata, and HTTP response data. responseConsumer :: req -> IORef (ResponseMetadata resp) -> HTTPResponseConsumer resp -- | Does not parse response. For debugging. instance ResponseConsumer r (HTTP.Response L.ByteString) where type ResponseMetadata (HTTP.Response L.ByteString) = () responseConsumer _ _ resp = do bss <- HTTP.responseBody resp $$+- CL.consume return resp { HTTP.responseBody = L.fromChunks bss } -- | Class for responses that are fully loaded into memory class AsMemoryResponse resp where type MemoryResponse resp :: * loadToMemory :: resp -> ResourceT IO (MemoryResponse resp) -- | Responses that have one main list in them, and perhaps some decoration. class ListResponse resp item | resp -> item where listResponse :: resp -> [item] -- | Associates a request type and a response type in a bi-directional way. -- -- This allows the type-checker to infer the response type when given -- the request type and vice versa. -- -- Note that the actual request generation and response parsing -- resides in 'SignQuery' and 'ResponseConsumer' respectively. class (SignQuery r, ResponseConsumer r a, Loggable (ResponseMetadata a)) => Transaction r a | r -> a -- | A transaction that may need to be split over multiple requests, for example because of upstream response size limits. class Transaction r a => IteratedTransaction r a | r -> a where nextIteratedRequest :: r -> a -> Maybe r -- | Signature version 4: ((region, service),(date,key)) type V4Key = ((B.ByteString,B.ByteString),(B.ByteString,B.ByteString)) -- | AWS access credentials. data Credentials = Credentials { -- | AWS Access Key ID. accessKeyID :: B.ByteString -- | AWS Secret Access Key. , secretAccessKey :: B.ByteString -- | Signing keys for signature version 4 , v4SigningKeys :: IORef [V4Key] -- | Signed IAM token , iamToken :: Maybe B.ByteString } instance Show Credentials where show c = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}" makeCredentials :: MonadIO io => B.ByteString -- ^ AWS Access Key ID -> B.ByteString -- ^ AWS Secret Access Key -> io Credentials makeCredentials accessKeyID secretAccessKey = liftIO $ do v4SigningKeys <- newIORef [] let iamToken = Nothing return Credentials { .. } -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'. -- -- Value: //@/.aws-keys@ credentialsDefaultFile :: MonadIO io => io FilePath credentialsDefaultFile = liftIO $ ( ".aws-keys") <$> getHomeDirectory -- | The key to be used in the access credential file that is loaded, when using 'loadCredentialsDefault'. -- -- Value: @default@ credentialsDefaultKey :: T.Text credentialsDefaultKey = "default" -- | Load credentials from a (text) file given a key name. -- -- The file consists of a sequence of lines, each in the following format: -- -- @keyName awsKeyID awsKeySecret@ loadCredentialsFromFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromFile file key = liftIO $ do exists <- doesFileExist file if exists then do contents <- map T.words . T.lines <$> T.readFile file Traversable.sequence $ do [_key, keyID, secret] <- find (hasKey key) contents return (makeCredentials (T.encodeUtf8 keyID) (T.encodeUtf8 secret)) else return Nothing where hasKey _ [] = False hasKey k (k2 : _) = k == k2 -- | Load credentials from the environment variables @AWS_ACCESS_KEY_ID@ and @AWS_ACCESS_KEY_SECRET@ -- (or @AWS_SECRET_ACCESS_KEY@), if possible. loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials) loadCredentialsFromEnv = liftIO $ do env <- getEnvironment let lk = flip lookup env keyID = lk "AWS_ACCESS_KEY_ID" secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY" Traversable.sequence (makeCredentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret)) loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials) loadCredentialsFromInstanceMetadata = liftIO $ HTTP.withManager $ \mgr -> do -- check if the path is routable avail <- liftIO $ hostAvailable "169.254.169.254" if not avail then return Nothing else do info <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam" "info" >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing) let infodict = info >>= A.decode :: Maybe (M.Map String String) info' = infodict >>= M.lookup "InstanceProfileArn" case info' of Just name -> do let name' = drop 1 $ dropWhile (/= '/') $ name creds <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam/security-credentials" name' >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing) -- this token lasts ~6 hours let dict = creds >>= A.decode :: Maybe (M.Map String String) keyID = dict >>= M.lookup "AccessKeyId" secret = dict >>= M.lookup "SecretAccessKey" token = dict >>= M.lookup "Token" ref <- liftIO $ newIORef [] return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret) <*> return ref <*> (Just . T.encodeUtf8 . T.pack <$> token)) Nothing -> return Nothing -- | Load credentials from environment variables if possible, or alternatively from a file with a given key name. -- -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. loadCredentialsFromEnvOrFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromEnvOrFile file key = do envcr <- loadCredentialsFromEnv case envcr of Just cr -> return (Just cr) Nothing -> loadCredentialsFromFile file key -- | Load credentials from environment variables if possible, or alternatively from the instance metadata store, or alternatively from a file with a given key name. -- -- See 'loadCredentialsFromEnv', 'loadCredentialsFromFile' and 'loadCredentialsFromInstanceMetadata' for details. loadCredentialsFromEnvOrFileOrInstanceMetadata :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromEnvOrFileOrInstanceMetadata file key = do envcr <- loadCredentialsFromEnv case envcr of Just cr -> return (Just cr) Nothing -> do filecr <- loadCredentialsFromFile file key case filecr of Just cr -> return (Just cr) Nothing -> loadCredentialsFromInstanceMetadata -- | Load credentials from environment variables if possible, or alternative from the default file with the default -- key name. -- -- Default file: //@/.aws-keys@ -- Default key name: @default@ -- -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. loadCredentialsDefault :: MonadIO io => io (Maybe Credentials) loadCredentialsDefault = do file <- credentialsDefaultFile loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey -- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols. data Protocol = HTTP | HTTPS deriving (Eq,Read,Show,Ord,Typeable) -- | The default port to be used for a protocol if no specific port is specified. defaultPort :: Protocol -> Int defaultPort HTTP = 80 defaultPort HTTPS = 443 -- | Request method. Not all request methods are supported by all services. data Method = Head -- ^ HEAD method. Put all request parameters in a query string and HTTP headers. | Get -- ^ GET method. Put all request parameters in a query string and HTTP headers. | PostQuery -- ^ POST method. Put all request parameters in a query string and HTTP headers, but send the query string -- as a POST payload | Post -- ^ POST method. Sends a service- and request-specific request body. | Put -- ^ PUT method. | Delete -- ^ DELETE method. deriving (Show, Eq, Ord) -- | HTTP method associated with a request method. httpMethod :: Method -> HTTP.Method httpMethod Head = "HEAD" httpMethod Get = "GET" httpMethod PostQuery = "POST" httpMethod Post = "POST" httpMethod Put = "PUT" httpMethod Delete = "DELETE" -- | A pre-signed medium-level request object. data SignedQuery = SignedQuery { -- | Request method. sqMethod :: !Method -- | Protocol to be used. , sqProtocol :: !Protocol -- | HTTP host. , sqHost :: !B.ByteString -- | IP port. , sqPort :: !Int -- | HTTP path. , sqPath :: !B.ByteString -- | Query string list (used with 'Get' and 'PostQuery'). , sqQuery :: !HTTP.Query -- | Request date/time. , sqDate :: !(Maybe UTCTime) -- | Authorization string (if applicable), for @Authorization@ header. See 'authorizationV4' , sqAuthorization :: !(Maybe (IO B.ByteString)) -- | Request body content type. , sqContentType :: !(Maybe B.ByteString) -- | Request body content MD5. , sqContentMd5 :: !(Maybe (Digest MD5)) -- | Additional Amazon "amz" headers. , sqAmzHeaders :: !HTTP.RequestHeaders -- | Additional non-"amz" headers. , sqOtherHeaders :: !HTTP.RequestHeaders -- | Request body (used with 'Post' and 'Put'). #if MIN_VERSION_http_conduit(2, 0, 0) , sqBody :: !(Maybe HTTP.RequestBody) #else , sqBody :: !(Maybe (HTTP.RequestBody (C.ResourceT IO))) #endif -- | String to sign. Note that the string is already signed, this is passed mostly for debugging purposes. , sqStringToSign :: !B.ByteString } --deriving (Show) -- | Create a HTTP request from a 'SignedQuery' object. #if MIN_VERSION_http_conduit(2, 0, 0) queryToHttpRequest :: SignedQuery -> IO HTTP.Request #else queryToHttpRequest :: SignedQuery -> IO (HTTP.Request (C.ResourceT IO)) #endif queryToHttpRequest SignedQuery{..} = do mauth <- maybe (return Nothing) (Just<$>) sqAuthorization return $ def { HTTP.method = httpMethod sqMethod , HTTP.secure = case sqProtocol of HTTP -> False HTTPS -> True , HTTP.host = sqHost , HTTP.port = sqPort , HTTP.path = sqPath , HTTP.queryString = if sqMethod == PostQuery then "" else HTTP.renderQuery False sqQuery , HTTP.requestHeaders = catMaybes [ checkDate (\d -> ("Date", fmtRfc822Time d)) sqDate , fmap (\c -> ("Content-Type", c)) contentType , fmap (\md5 -> ("Content-MD5", Base64.encode $ toBytes md5)) sqContentMd5 , fmap (\auth -> ("Authorization", auth)) mauth] ++ sqAmzHeaders ++ sqOtherHeaders , HTTP.requestBody = -- An explicityly defined body parameter should overwrite everything else. case sqBody of Just x -> x Nothing -> -- a POST query should convert its query string into the body case sqMethod of PostQuery -> HTTP.RequestBodyLBS . Blaze.toLazyByteString $ HTTP.renderQueryBuilder False sqQuery _ -> HTTP.RequestBodyBuilder 0 mempty , HTTP.decompress = HTTP.alwaysDecompress , HTTP.checkStatus = \_ _ _ -> Nothing , HTTP.redirectCount = 10 } where checkDate f mb = maybe (f <$> mb) (const Nothing) $ lookup "date" sqOtherHeaders -- An explicitly defined content-type should override everything else. contentType = sqContentType `mplus` defContentType defContentType = case sqMethod of PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8" _ -> Nothing -- | Create a URI fro a 'SignedQuery' object. -- -- Unused / incompatible fields will be silently ignored. queryToUri :: SignedQuery -> B.ByteString queryToUri SignedQuery{..} = B.concat [ case sqProtocol of HTTP -> "http://" HTTPS -> "https://" , sqHost , if sqPort == defaultPort sqProtocol then "" else T.encodeUtf8 . T.pack $ ':' : show sqPort , sqPath , HTTP.renderQuery True sqQuery ] -- | Whether to restrict the signature validity with a plain timestamp, or with explicit expiration -- (absolute or relative). data TimeInfo = Timestamp -- ^ Use a simple timestamp to let AWS check the request validity. | ExpiresAt { fromExpiresAt :: UTCTime } -- ^ Let requests expire at a specific fixed time. | ExpiresIn { fromExpiresIn :: NominalDiffTime } -- ^ Let requests expire a specific number of seconds after they -- were generated. deriving (Show) -- | Like 'TimeInfo', but with all relative times replaced by absolute UTC. data AbsoluteTimeInfo = AbsoluteTimestamp { fromAbsoluteTimestamp :: UTCTime } | AbsoluteExpires { fromAbsoluteExpires :: UTCTime } deriving (Show) -- | Just the UTC time value. fromAbsoluteTimeInfo :: AbsoluteTimeInfo -> UTCTime fromAbsoluteTimeInfo (AbsoluteTimestamp time) = time fromAbsoluteTimeInfo (AbsoluteExpires time) = time -- | Convert 'TimeInfo' to 'AbsoluteTimeInfo' given the current UTC time. makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo makeAbsoluteTimeInfo Timestamp now = AbsoluteTimestamp now makeAbsoluteTimeInfo (ExpiresAt t) _ = AbsoluteExpires t makeAbsoluteTimeInfo (ExpiresIn s) now = AbsoluteExpires $ addUTCTime s now -- | Data that is always required for signing requests. data SignatureData = SignatureData { -- | Expiration or timestamp. signatureTimeInfo :: AbsoluteTimeInfo -- | Current time. , signatureTime :: UTCTime -- | Access credentials. , signatureCredentials :: Credentials } -- | Create signature data using the current system time. signatureData :: TimeInfo -> Credentials -> IO SignatureData signatureData rti cr = do now <- getCurrentTime let ti = makeAbsoluteTimeInfo rti now return SignatureData { signatureTimeInfo = ti, signatureTime = now, signatureCredentials = cr } -- | Tag type for normal queries. data NormalQuery -- | Tag type for URI-only queries. data UriOnlyQuery -- | A "signable" request object. Assembles together the Query, and signs it in one go. class SignQuery request where -- | Additional information, like API endpoints and service-specific preferences. type ServiceConfiguration request :: * {- Query Type -} -> * -- | Create a 'SignedQuery' from a request, additional 'Info', and 'SignatureData'. signQuery :: request -> ServiceConfiguration request queryType -> SignatureData -> SignedQuery -- | Supported crypto hashes for the signature. data AuthorizationHash = HmacSHA1 | HmacSHA256 deriving (Show) -- | Authorization hash identifier as expected by Amazon. amzHash :: AuthorizationHash -> B.ByteString amzHash HmacSHA1 = "HmacSHA1" amzHash HmacSHA256 = "HmacSHA256" -- | Create a signature. Usually, AWS wants a specifically constructed string to be signed. -- -- The signature is a HMAC-based hash of the string and the secret access key. signature :: Credentials -> AuthorizationHash -> B.ByteString -> B.ByteString signature cr ah input = Base64.encode sig where sig = case ah of HmacSHA1 -> computeSig SHA1 HmacSHA256 -> computeSig SHA256 computeSig :: HashAlgorithm a => a -> ByteString computeSig t = toBytes (hmacAlg t (secretAccessKey cr) input) -- | Use this to create the Authorization header to set into 'sqAuthorization'. -- See : you must create the -- canonical request as explained by Step 1 and this function takes care of Steps 2 and 3. authorizationV4 :: SignatureData -> AuthorizationHash -> B.ByteString -- ^ region, e.g. us-east-1 -> B.ByteString -- ^ service, e.g. dynamodb -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target -> B.ByteString -- ^ canonicalRequest (before hashing) -> IO B.ByteString authorizationV4 sd ah region service headers canonicalRequest = do let ref = v4SigningKeys $ signatureCredentials sd date = fmtTime "%Y%m%d" $ signatureTime sd mkHmac k i = case ah of HmacSHA1 -> toBytes (hmac k i :: HMAC SHA1) HmacSHA256 -> toBytes (hmac k i :: HMAC SHA256) mkHash i = case ah of HmacSHA1 -> toBytes (hash i :: Digest SHA1) HmacSHA256 -> toBytes (hash i :: Digest SHA256) alg = case ah of HmacSHA1 -> "AWS4-HMAC-SHA1" HmacSHA256 -> "AWS4-HMAC-SHA256" -- Lookup existing signing key allkeys <- readIORef ref let mkey = case lookup (region,service) allkeys of Just (d,k) | d /= date -> Nothing | otherwise -> Just k Nothing -> Nothing -- possibly create a new signing key key <- case mkey of Just k -> return k Nothing -> atomicModifyIORef ref $ \keylist -> let secretKey = secretAccessKey $ signatureCredentials sd kDate = mkHmac ("AWS4" <> secretKey) date kRegion = mkHmac kDate region kService = mkHmac kRegion service kSigning = mkHmac kService "aws4_request" lstK = (region,service) keylist' = (lstK,(date,kSigning)) : filter ((lstK/=).fst) keylist in (keylist', kSigning) -- now do the signature let canonicalRequestHash = Base16.encode $ mkHash canonicalRequest stringToSign = B.concat [ alg , "\n" , fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd , "\n" , date , "/" , region , "/" , service , "/aws4_request\n" , canonicalRequestHash ] sig = Base16.encode $ mkHmac key stringToSign -- finally, return the header return $ B.concat [ alg , " Credential=" , accessKeyID (signatureCredentials sd) , "/" , date , "/" , region , "/" , service , "/aws4_request," , "SignedHeaders=" , headers , ",Signature=" , sig ] -- | Default configuration for a specific service. class DefaultServiceConfiguration config where -- | Default service configuration. defServiceConfig :: config -- | Default debugging-only configuration. (Normally using HTTP instead of HTTPS for easier debugging.) debugServiceConfig :: config debugServiceConfig = defServiceConfig -- | @queryList f prefix xs@ constructs a query list from a list of -- elements @xs@, using a common prefix @prefix@, and a transformer -- function @f@. -- -- A dot (@.@) is interspersed between prefix and generated key. -- -- Example: -- -- @queryList swap \"pfx\" [(\"a\", \"b\"), (\"c\", \"d\")]@ evaluates to @[(\"pfx.b\", \"a\"), (\"pfx.d\", \"c\")]@ -- (except with ByteString instead of String, of course). queryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> [(B.ByteString, B.ByteString)] queryList f prefix xs = concat $ zipWith combine prefixList (map f xs) where prefixList = map (dot prefix . BU.fromString . show) [(1 :: Int) ..] combine pf = map $ first (pf `dot`) dot x y = B.concat [x, BU.fromString ".", y] -- | A \"true\"/\"false\" boolean as requested by some services. awsBool :: Bool -> B.ByteString awsBool True = "true" awsBool False = "false" -- | \"true\" awsTrue :: B.ByteString awsTrue = awsBool True -- | \"false\" awsFalse :: B.ByteString awsFalse = awsBool False -- | Format time according to a format string, as a ByteString. fmtTime :: String -> UTCTime -> B.ByteString fmtTime s t = BU.fromString $ formatTime defaultTimeLocale s t rfc822Time :: String rfc822Time = "%a, %_d %b %Y %H:%M:%S GMT" -- | Format time in RFC 822 format. fmtRfc822Time :: UTCTime -> B.ByteString fmtRfc822Time = fmtTime rfc822Time -- | Format time in yyyy-mm-ddThh-mm-ss format. fmtAmzTime :: UTCTime -> B.ByteString fmtAmzTime = fmtTime "%Y-%m-%dT%H:%M:%S" -- | Format time as seconds since the Unix epoch. fmtTimeEpochSeconds :: UTCTime -> B.ByteString fmtTimeEpochSeconds = fmtTime "%s" -- | Parse HTTP-date (section 3.3.1 of RFC 2616) parseHttpDate :: String -> Maybe UTCTime parseHttpDate s = p "%a, %d %b %Y %H:%M:%S GMT" s -- rfc1123-date <|> p "%A, %d-%b-%y %H:%M:%S GMT" s -- rfc850-date <|> p "%a %b %_d %H:%M:%S %Y" s -- asctime-date <|> p "%Y-%m-%dT%H:%M:%S%QZ" s -- iso 8601 <|> p "%Y-%m-%dT%H:%M:%S%Q%Z" s -- iso 8601 where p = parseTime defaultTimeLocale -- | HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style) httpDate1 :: String httpDate1 = "%a, %d %b %Y %H:%M:%S GMT" -- rfc1123-date -- | Format (as Text) HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style) textHttpDate :: UTCTime -> T.Text textHttpDate = T.pack . formatTime defaultTimeLocale httpDate1 iso8601UtcDate :: String iso8601UtcDate = "%Y-%m-%dT%H:%M:%S%QZ" -- | Parse a two-digit hex number. readHex2 :: [Char] -> Maybe Word8 readHex2 [c1,c2] = do n1 <- readHex1 c1 n2 <- readHex1 c2 return . fromIntegral $ n1 * 16 + n2 where readHex1 c | c >= '0' && c <= '9' = Just $ ord c - ord '0' | c >= 'A' && c <= 'F' = Just $ ord c - ord 'A' + 10 | c >= 'a' && c <= 'f' = Just $ ord c - ord 'a' + 10 readHex1 _ = Nothing readHex2 _ = Nothing -- XML -- | An error that occurred during XML parsing / validation. newtype XmlException = XmlException { xmlErrorMessage :: String } deriving (Show, Typeable) instance E.Exception XmlException -- | An error that occurred during header parsing / validation. newtype HeaderException = HeaderException { headerErrorMessage :: String } deriving (Show, Typeable) instance E.Exception HeaderException -- | An error that occurred during form parsing / validation. newtype FormException = FormException { formErrorMesage :: String } deriving (Show, Typeable) instance E.Exception FormException -- | No credentials were found and an invariant was violated. newtype NoCredentialsException = NoCredentialsException { noCredentialsErrorMessage :: String } deriving (Show, Typeable) instance E.Exception NoCredentialsException -- | A specific element (case-insensitive, ignoring namespace - sadly necessary), extracting only the textual contents. elContent :: T.Text -> Cursor -> [T.Text] elContent name = laxElement name &/ content -- | Like 'elContent', but extracts 'String's instead of 'T.Text'. elCont :: T.Text -> Cursor -> [String] elCont name = laxElement name &/ content &| T.unpack -- | Extract the first element from a parser result list, and throw an 'XmlException' if the list is empty. force :: MonadThrow m => String -> [a] -> m a force = Cu.force . XmlException -- | Extract the first element from a monadic parser result list, and throw an 'XmlException' if the list is empty. forceM :: MonadThrow m => String -> [m a] -> m a forceM = Cu.forceM . XmlException -- | Read an integer from a 'T.Text', throwing an 'XmlException' on failure. textReadInt :: (MonadThrow m, Num a) => T.Text -> m a textReadInt s = case reads $ T.unpack s of [(n,"")] -> return $ fromInteger n _ -> throwM $ XmlException "Invalid Integer" -- | Read an integer from a 'String', throwing an 'XmlException' on failure. readInt :: (MonadThrow m, Num a) => String -> m a readInt s = case reads s of [(n,"")] -> return $ fromInteger n _ -> throwM $ XmlException "Invalid Integer" -- | Create a complete 'HTTPResponseConsumer' from a simple function that takes a 'Cu.Cursor' to XML in the response -- body. -- -- This function is highly recommended for any services that parse relatively short XML responses. (If status and response -- headers are required, simply take them as function parameters, and pass them through to this function.) xmlCursorConsumer :: (Monoid m) => (Cu.Cursor -> Response m a) -> IORef m -> HTTPResponseConsumer a xmlCursorConsumer parse metadataRef res = do doc <- HTTP.responseBody res $$+- XML.sinkDoc XML.def let cursor = Cu.fromDocument doc let Response metadata x = parse cursor liftIO $ tellMetadataRef metadataRef metadata case x of Left err -> liftIO $ throwM err Right v -> return v aws-0.13.0/Aws/Network.hs0000644000000000000000000000124612615132266013301 0ustar0000000000000000module Aws.Network where import Data.Maybe import Control.Exception import Network.BSD (getProtocolNumber) import Network.Socket import System.Timeout -- Make a good guess if a host is reachable. hostAvailable :: String -> IO Bool hostAvailable h = do sock <- getProtocolNumber "tcp" >>= socket AF_INET Stream addr <- (addrAddress . head) `fmap` getAddrInfo (Just (defaultHints { addrFlags = [ AI_PASSIVE ] } )) (Just h) (Just "80") case addr of remote@(SockAddrInet _ _) -> do v <- catch (timeout 100000 (connect sock remote) >>= return . isJust) (\(_ :: SomeException) -> return False) sClose sock return v _ -> return False aws-0.13.0/Aws/S3.hs0000644000000000000000000000016112615132266012130 0ustar0000000000000000module Aws.S3 ( module Aws.S3.Commands , module Aws.S3.Core ) where import Aws.S3.Commands import Aws.S3.Core aws-0.13.0/Aws/Ses.hs0000644000000000000000000000020012615132266012367 0ustar0000000000000000module Aws.Ses ( module Aws.Ses.Commands , module Aws.Ses.Core ) where import Aws.Ses.Commands import Aws.Ses.Core aws-0.13.0/Aws/Sqs.hs0000644000000000000000000000016612615132266012416 0ustar0000000000000000module Aws.Sqs ( module Aws.Sqs.Commands , module Aws.Sqs.Core ) where import Aws.Sqs.Commands import Aws.Sqs.Core aws-0.13.0/Aws/S3/0000755000000000000000000000000012615132266011576 5ustar0000000000000000aws-0.13.0/Aws/S3/Commands.hs0000644000000000000000000000157412615132266013702 0ustar0000000000000000module Aws.S3.Commands ( module Aws.S3.Commands.CopyObject , module Aws.S3.Commands.DeleteBucket , module Aws.S3.Commands.DeleteObject , module Aws.S3.Commands.DeleteObjects , module Aws.S3.Commands.GetBucket , module Aws.S3.Commands.GetBucketLocation , module Aws.S3.Commands.GetObject , module Aws.S3.Commands.GetService , module Aws.S3.Commands.HeadObject , module Aws.S3.Commands.PutBucket , module Aws.S3.Commands.PutObject , module Aws.S3.Commands.Multipart ) where import Aws.S3.Commands.CopyObject import Aws.S3.Commands.DeleteBucket import Aws.S3.Commands.DeleteObject import Aws.S3.Commands.DeleteObjects import Aws.S3.Commands.GetBucket import Aws.S3.Commands.GetBucketLocation import Aws.S3.Commands.GetObject import Aws.S3.Commands.GetService import Aws.S3.Commands.HeadObject import Aws.S3.Commands.PutBucket import Aws.S3.Commands.PutObject import Aws.S3.Commands.Multipart aws-0.13.0/Aws/S3/Core.hs0000644000000000000000000005050012615132266013022 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns #-} module Aws.S3.Core where import Aws.Core import Control.Arrow ((***)) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (MonadThrow, throwM) import Crypto.Hash import Data.Byteable import Data.Conduit (($$+-)) import Data.Function import Data.Functor ((<$>)) import Data.IORef import Data.List import Data.Maybe import Data.Monoid import Control.Applicative ((<|>)) import Data.Time import Data.Typeable #if MIN_VERSION_time(1,5,0) import Data.Time.Format #else import System.Locale #endif import Text.XML.Cursor (($/), (&|)) import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Base64 as Base64 import qualified Data.CaseInsensitive as CI import qualified Data.Conduit as C import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import qualified Text.XML as XML import qualified Text.XML.Cursor as Cu data S3Authorization = S3AuthorizationHeader | S3AuthorizationQuery deriving (Show) data RequestStyle = PathStyle -- ^ Requires correctly setting region endpoint, but allows non-DNS compliant bucket names in the US standard region. | BucketStyle -- ^ Bucket name must be DNS compliant. | VHostStyle deriving (Show) data S3Configuration qt = S3Configuration { s3Protocol :: Protocol , s3Endpoint :: B.ByteString , s3RequestStyle :: RequestStyle , s3Port :: Int , s3ServerSideEncryption :: Maybe ServerSideEncryption , s3UseUri :: Bool , s3DefaultExpiry :: NominalDiffTime } deriving (Show) instance DefaultServiceConfiguration (S3Configuration NormalQuery) where defServiceConfig = s3 HTTPS s3EndpointUsClassic False debugServiceConfig = s3 HTTP s3EndpointUsClassic False instance DefaultServiceConfiguration (S3Configuration UriOnlyQuery) where defServiceConfig = s3 HTTPS s3EndpointUsClassic True debugServiceConfig = s3 HTTP s3EndpointUsClassic True s3EndpointUsClassic :: B.ByteString s3EndpointUsClassic = "s3.amazonaws.com" s3EndpointUsWest :: B.ByteString s3EndpointUsWest = "s3-us-west-1.amazonaws.com" s3EndpointUsWest2 :: B.ByteString s3EndpointUsWest2 = "s3-us-west-2.amazonaws.com" s3EndpointEu :: B.ByteString s3EndpointEu = "s3-eu-west-1.amazonaws.com" s3EndpointApSouthEast :: B.ByteString s3EndpointApSouthEast = "s3-ap-southeast-1.amazonaws.com" s3EndpointApSouthEast2 :: B.ByteString s3EndpointApSouthEast2 = "s3-ap-southeast-2.amazonaws.com" s3EndpointApNorthEast :: B.ByteString s3EndpointApNorthEast = "s3-ap-northeast-1.amazonaws.com" s3 :: Protocol -> B.ByteString -> Bool -> S3Configuration qt s3 protocol endpoint uri = S3Configuration { s3Protocol = protocol , s3Endpoint = endpoint , s3RequestStyle = BucketStyle , s3Port = defaultPort protocol , s3ServerSideEncryption = Nothing , s3UseUri = uri , s3DefaultExpiry = 15*60 } type ErrorCode = T.Text data S3Error = S3Error { s3StatusCode :: HTTP.Status , s3ErrorCode :: ErrorCode -- Error/Code , s3ErrorMessage :: T.Text -- Error/Message , s3ErrorResource :: Maybe T.Text -- Error/Resource , s3ErrorHostId :: Maybe T.Text -- Error/HostId , s3ErrorAccessKeyId :: Maybe T.Text -- Error/AWSAccessKeyId , s3ErrorStringToSign :: Maybe B.ByteString -- Error/StringToSignBytes (hexadecimal encoding) , s3ErrorBucket :: Maybe T.Text -- Error/Bucket , s3ErrorEndpointRaw :: Maybe T.Text -- Error/Endpoint (i.e. correct bucket location) , s3ErrorEndpoint :: Maybe B.ByteString -- Error/Endpoint without the bucket prefix } deriving (Show, Typeable) instance C.Exception S3Error data S3Metadata = S3Metadata { s3MAmzId2 :: Maybe T.Text , s3MRequestId :: Maybe T.Text } deriving (Show, Typeable) instance Monoid S3Metadata where mempty = S3Metadata Nothing Nothing S3Metadata a1 r1 `mappend` S3Metadata a2 r2 = S3Metadata (a1 `mplus` a2) (r1 `mplus` r2) instance Loggable S3Metadata where toLogText (S3Metadata id2 rid) = "S3: request ID=" `mappend` fromMaybe "" rid `mappend` ", x-amz-id-2=" `mappend` fromMaybe "" id2 data S3Query = S3Query { s3QMethod :: Method , s3QBucket :: Maybe B.ByteString , s3QObject :: Maybe B.ByteString , s3QSubresources :: HTTP.Query , s3QQuery :: HTTP.Query , s3QContentType :: Maybe B.ByteString , s3QContentMd5 :: Maybe (Digest MD5) , s3QAmzHeaders :: HTTP.RequestHeaders , s3QOtherHeaders :: HTTP.RequestHeaders #if MIN_VERSION_http_conduit(2, 0, 0) , s3QRequestBody :: Maybe HTTP.RequestBody #else , s3QRequestBody :: Maybe (HTTP.RequestBody (C.ResourceT IO)) #endif } instance Show S3Query where show S3Query{..} = "S3Query [" ++ " method: " ++ show s3QMethod ++ " ; bucket: " ++ show s3QBucket ++ " ; subresources: " ++ show s3QSubresources ++ " ; query: " ++ show s3QQuery ++ " ; request body: " ++ (case s3QRequestBody of Nothing -> "no"; _ -> "yes") ++ "]" s3SignQuery :: S3Query -> S3Configuration qt -> SignatureData -> SignedQuery s3SignQuery S3Query{..} S3Configuration{..} SignatureData{..} = SignedQuery { sqMethod = s3QMethod , sqProtocol = s3Protocol , sqHost = B.intercalate "." $ catMaybes host , sqPort = s3Port , sqPath = mconcat $ catMaybes path , sqQuery = sortedSubresources ++ s3QQuery ++ authQuery :: HTTP.Query , sqDate = Just signatureTime , sqAuthorization = authorization , sqContentType = s3QContentType , sqContentMd5 = s3QContentMd5 , sqAmzHeaders = amzHeaders , sqOtherHeaders = s3QOtherHeaders , sqBody = s3QRequestBody , sqStringToSign = stringToSign } where amzHeaders = merge $ sortBy (compare `on` fst) (s3QAmzHeaders ++ (fmap (\(k, v) -> (CI.mk k, v)) iamTok)) where merge (x1@(k1,v1):x2@(k2,v2):xs) | k1 == k2 = merge ((k1, B8.intercalate "," [v1, v2]) : xs) | otherwise = x1 : merge (x2 : xs) merge xs = xs urlEncodedS3QObject = HTTP.urlEncode False <$> s3QObject (host, path) = case s3RequestStyle of PathStyle -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket, urlEncodedS3QObject]) BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/", urlEncodedS3QObject]) VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/", urlEncodedS3QObject]) sortedSubresources = sort s3QSubresources canonicalizedResource = Blaze8.fromChar '/' `mappend` maybe mempty (\s -> Blaze.copyByteString s `mappend` Blaze8.fromChar '/') s3QBucket `mappend` maybe mempty Blaze.copyByteString urlEncodedS3QObject `mappend` HTTP.renderQueryBuilder True sortedSubresources ti = case (s3UseUri, signatureTimeInfo) of (False, ti') -> ti' (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time (True, AbsoluteExpires time) -> AbsoluteExpires time sig = signature signatureCredentials HmacSHA1 stringToSign iamTok = maybe [] (\x -> [("x-amz-security-token", x)]) (iamToken signatureCredentials) stringToSign = Blaze.toByteString . mconcat . intersperse (Blaze8.fromChar '\n') . concat $ [[Blaze.copyByteString $ httpMethod s3QMethod] , [maybe mempty (Blaze.copyByteString . Base64.encode . toBytes) s3QContentMd5] , [maybe mempty Blaze.copyByteString s3QContentType] , [Blaze.copyByteString $ case ti of AbsoluteTimestamp time -> fmtRfc822Time time AbsoluteExpires time -> fmtTimeEpochSeconds time] , map amzHeader amzHeaders , [canonicalizedResource] ] where amzHeader (k, v) = Blaze.copyByteString (CI.foldedCase k) `mappend` Blaze8.fromChar ':' `mappend` Blaze.copyByteString v (authorization, authQuery) = case ti of AbsoluteTimestamp _ -> (Just $ return $ B.concat ["AWS ", accessKeyID signatureCredentials, ":", sig], []) AbsoluteExpires time -> (Nothing, HTTP.toQuery $ makeAuthQuery time) makeAuthQuery time = [("Expires" :: B8.ByteString, fmtTimeEpochSeconds time) , ("AWSAccessKeyId", accessKeyID signatureCredentials) , ("SignatureMethod", "HmacSHA256") , ("Signature", sig)] ++ iamTok s3ResponseConsumer :: HTTPResponseConsumer a -> IORef S3Metadata -> HTTPResponseConsumer a s3ResponseConsumer inner metadataRef = s3BinaryResponseConsumer inner' metadataRef where inner' resp = do !res <- inner resp C.closeResumableSource (HTTP.responseBody resp) return res s3BinaryResponseConsumer :: HTTPResponseConsumer a -> IORef S3Metadata -> HTTPResponseConsumer a s3BinaryResponseConsumer inner metadata resp = do let headerString = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp) let amzId2 = headerString "x-amz-id-2" let requestId = headerString "x-amz-request-id" let m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId } liftIO $ tellMetadataRef metadata m if HTTP.responseStatus resp >= HTTP.status300 then s3ErrorResponseConsumer resp else inner resp s3XmlResponseConsumer :: (Cu.Cursor -> Response S3Metadata a) -> IORef S3Metadata -> HTTPResponseConsumer a s3XmlResponseConsumer parse metadataRef = s3ResponseConsumer (xmlCursorConsumer parse metadataRef) metadataRef s3ErrorResponseConsumer :: HTTPResponseConsumer a s3ErrorResponseConsumer resp = do doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def let cursor = Cu.fromDocument doc liftIO $ case parseError cursor of Right err -> throwM err Left otherErr -> throwM otherErr where parseError :: Cu.Cursor -> Either C.SomeException S3Error parseError root = do code <- force "Missing error Code" $ root $/ elContent "Code" message <- force "Missing error Message" $ root $/ elContent "Message" let resource = listToMaybe $ root $/ elContent "Resource" hostId = listToMaybe $ root $/ elContent "HostId" accessKeyId = listToMaybe $ root $/ elContent "AWSAccessKeyId" bucket = listToMaybe $ root $/ elContent "Bucket" endpointRaw = listToMaybe $ root $/ elContent "Endpoint" endpoint = T.encodeUtf8 <$> (T.stripPrefix (fromMaybe "" bucket <> ".") =<< endpointRaw) stringToSign = do unprocessed <- listToMaybe $ root $/ elCont "StringToSignBytes" bytes <- mapM readHex2 $ words unprocessed return $ B.pack bytes return S3Error { s3StatusCode = HTTP.responseStatus resp , s3ErrorCode = code , s3ErrorMessage = message , s3ErrorResource = resource , s3ErrorHostId = hostId , s3ErrorAccessKeyId = accessKeyId , s3ErrorStringToSign = stringToSign , s3ErrorBucket = bucket , s3ErrorEndpointRaw = endpointRaw , s3ErrorEndpoint = endpoint } type CanonicalUserId = T.Text data UserInfo = UserInfo { userId :: CanonicalUserId , userDisplayName :: T.Text } deriving (Show) parseUserInfo :: MonadThrow m => Cu.Cursor -> m UserInfo parseUserInfo el = do id_ <- force "Missing user ID" $ el $/ elContent "ID" displayName <- force "Missing user DisplayName" $ el $/ elContent "DisplayName" return UserInfo { userId = id_, userDisplayName = displayName } data CannedAcl = AclPrivate | AclPublicRead | AclPublicReadWrite | AclAuthenticatedRead | AclBucketOwnerRead | AclBucketOwnerFullControl | AclLogDeliveryWrite deriving (Show) writeCannedAcl :: CannedAcl -> T.Text writeCannedAcl AclPrivate = "private" writeCannedAcl AclPublicRead = "public-read" writeCannedAcl AclPublicReadWrite = "public-read-write" writeCannedAcl AclAuthenticatedRead = "authenticated-read" writeCannedAcl AclBucketOwnerRead = "bucket-owner-read" writeCannedAcl AclBucketOwnerFullControl = "bucket-owner-full-control" writeCannedAcl AclLogDeliveryWrite = "log-delivery-write" data StorageClass = Standard | StandardInfrequentAccess | ReducedRedundancy | Glacier | OtherStorageClass T.Text deriving (Show) parseStorageClass :: T.Text -> StorageClass parseStorageClass "STANDARD" = Standard parseStorageClass "STANDARD_IA" = StandardInfrequentAccess parseStorageClass "REDUCED_REDUNDANCY" = ReducedRedundancy parseStorageClass "GLACIER" = Glacier parseStorageClass s = OtherStorageClass s writeStorageClass :: StorageClass -> T.Text writeStorageClass Standard = "STANDARD" writeStorageClass StandardInfrequentAccess = "STANDARD_IA" writeStorageClass ReducedRedundancy = "REDUCED_REDUNDANCY" writeStorageClass Glacier = "GLACIER" writeStorageClass (OtherStorageClass s) = s data ServerSideEncryption = AES256 deriving (Show) parseServerSideEncryption :: MonadThrow m => T.Text -> m ServerSideEncryption parseServerSideEncryption "AES256" = return AES256 parseServerSideEncryption s = throwM . XmlException $ "Invalid Server Side Encryption: " ++ T.unpack s writeServerSideEncryption :: ServerSideEncryption -> T.Text writeServerSideEncryption AES256 = "AES256" type Bucket = T.Text data BucketInfo = BucketInfo { bucketName :: Bucket , bucketCreationDate :: UTCTime } deriving (Show) type Object = T.Text data ObjectId = ObjectId { oidBucket :: Bucket , oidObject :: Object , oidVersion :: Maybe T.Text } deriving (Show) data ObjectInfo = ObjectInfo { objectKey :: T.Text , objectLastModified :: UTCTime , objectETag :: T.Text , objectSize :: Integer , objectStorageClass :: StorageClass , objectOwner :: Maybe UserInfo } deriving (Show) parseObjectInfo :: MonadThrow m => Cu.Cursor -> m ObjectInfo parseObjectInfo el = do key <- force "Missing object Key" $ el $/ elContent "Key" let time s = case (parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s) <|> (parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" $ T.unpack s) of Nothing -> throwM $ XmlException "Invalid time" Just v -> return v lastModified <- forceM "Missing object LastModified" $ el $/ elContent "LastModified" &| time eTag <- force "Missing object ETag" $ el $/ elContent "ETag" size <- forceM "Missing object Size" $ el $/ elContent "Size" &| textReadInt storageClass <- forceM "Missing object StorageClass" $ el $/ elContent "StorageClass" &| return . parseStorageClass owner <- case el $/ Cu.laxElement "Owner" &| parseUserInfo of (x:_) -> fmap' Just x [] -> return Nothing return ObjectInfo{ objectKey = key , objectLastModified = lastModified , objectETag = eTag , objectSize = size , objectStorageClass = storageClass , objectOwner = owner } where fmap' :: Monad m => (a -> b) -> m a -> m b fmap' f ma = ma >>= return . f data ObjectMetadata = ObjectMetadata { omDeleteMarker :: Bool , omETag :: T.Text , omLastModified :: UTCTime , omVersionId :: Maybe T.Text -- TODO: -- , omExpiration :: Maybe (UTCTime, T.Text) , omUserMetadata :: [(T.Text, T.Text)] , omMissingUserMetadata :: Maybe T.Text , omServerSideEncryption :: Maybe ServerSideEncryption } deriving (Show) parseObjectMetadata :: MonadThrow m => HTTP.ResponseHeaders -> m ObjectMetadata parseObjectMetadata h = ObjectMetadata `liftM` deleteMarker `ap` etag `ap` lastModified `ap` return versionId -- `ap` expiration `ap` return userMetadata `ap` return missingUserMetadata `ap` serverSideEncryption where deleteMarker = case B8.unpack `fmap` lookup "x-amz-delete-marker" h of Nothing -> return False Just "true" -> return True Just "false" -> return False Just x -> throwM $ HeaderException ("Invalid x-amz-delete-marker " ++ x) etag = case T.decodeUtf8 `fmap` lookup "ETag" h of Just x -> return x Nothing -> throwM $ HeaderException "ETag missing" lastModified = case B8.unpack `fmap` lookup "Last-Modified" h of Just ts -> case parseHttpDate ts of Just t -> return t Nothing -> throwM $ HeaderException ("Invalid Last-Modified: " ++ ts) Nothing -> throwM $ HeaderException "Last-Modified missing" versionId = T.decodeUtf8 `fmap` lookup "x-amz-version-id" h -- expiration = return undefined userMetadata = flip mapMaybe ht $ \(k, v) -> do i <- T.stripPrefix "x-amz-meta-" k return (i, v) missingUserMetadata = T.decodeUtf8 `fmap` lookup "x-amz-missing-meta" h serverSideEncryption = case T.decodeUtf8 `fmap` lookup "x-amz-server-side-encryption" h of Just x -> return $ parseServerSideEncryption x Nothing -> return Nothing ht = map ((T.decodeUtf8 . CI.foldedCase) *** T.decodeUtf8) h type LocationConstraint = T.Text locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationEuFrankfurt, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: LocationConstraint locationUsClassic = "" locationUsWest = "us-west-1" locationUsWest2 = "us-west-2" locationEu = "EU" locationEuFrankfurt = "eu-central-1" locationApSouthEast = "ap-southeast-1" locationApSouthEast2 = "ap-southeast-2" locationApNorthEast = "ap-northeast-1" locationSA = "sa-east-1" normaliseLocation :: LocationConstraint -> LocationConstraint normaliseLocation location | location == "eu-west-1" = locationEu | otherwise = location aws-0.13.0/Aws/S3/Commands/0000755000000000000000000000000012615132266013337 5ustar0000000000000000aws-0.13.0/Aws/S3/Commands/DeleteObjects.hs0000644000000000000000000001165412615132266016416 0ustar0000000000000000module Aws.S3.Commands.DeleteObjects where import Aws.Core import Aws.S3.Core import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import qualified Text.XML as XML import qualified Text.XML.Cursor as Cu import Text.XML.Cursor (($/), (&|)) import Crypto.Hash import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 ({- IsString -}) import Control.Applicative ((<$>)) data DeleteObjects = DeleteObjects { dosBucket :: Bucket , dosObjects :: [(Object, Maybe T.Text)] -- snd is an optional versionId , dosQuiet :: Bool , dosMultiFactorAuthentication :: Maybe T.Text } deriving (Show) -- simple use case: neither mfa, nor version specified, quiet deleteObjects :: Bucket -> [T.Text] -> DeleteObjects deleteObjects bucket objs = DeleteObjects { dosBucket = bucket , dosObjects = zip objs $ repeat Nothing , dosQuiet = True , dosMultiFactorAuthentication = Nothing } data DeleteObjectsResponse = DeleteObjectsResponse { dorDeleted :: [DORDeleted] , dorErrors :: [DORErrors] } deriving (Show) --omitting DeleteMarker because it appears superfluous data DORDeleted = DORDeleted { ddKey :: T.Text , ddVersionId :: Maybe T.Text , ddDeleteMarkerVersionId :: Maybe T.Text } deriving (Show) data DORErrors = DORErrors { deKey :: T.Text , deCode :: T.Text , deMessage :: T.Text } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery DeleteObjects where type ServiceConfiguration DeleteObjects = S3Configuration signQuery DeleteObjects {..} = s3SignQuery S3Query { s3QMethod = Post , s3QBucket = Just $ T.encodeUtf8 dosBucket , s3QSubresources = HTTP.toQuery [("delete" :: B.ByteString, Nothing :: Maybe B.ByteString)] , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Just $ hashlazy dosBody , s3QObject = Nothing , s3QAmzHeaders = maybeToList $ (("x-amz-mfa", ) . T.encodeUtf8) <$> dosMultiFactorAuthentication , s3QOtherHeaders = [] , s3QRequestBody = Just $ HTTP.RequestBodyLBS dosBody } where dosBody = XML.renderLBS XML.def XML.Document { XML.documentPrologue = XML.Prologue [] Nothing [] , XML.documentRoot = root , XML.documentEpilogue = [] } root = XML.Element { XML.elementName = "Delete" , XML.elementAttributes = M.empty , XML.elementNodes = quietNode dosQuiet : (objectNode <$> dosObjects) } objectNode (obj, mbVersion) = XML.NodeElement XML.Element { XML.elementName = "Object" , XML.elementAttributes = M.empty , XML.elementNodes = keyNode obj : maybeToList (versionNode <$> mbVersion) } versionNode = toNode "VersionId" keyNode = toNode "Key" quietNode b = toNode "Quiet" $ if b then "true" else "false" toNode name content = XML.NodeElement XML.Element { XML.elementName = name , XML.elementAttributes = M.empty , XML.elementNodes = [XML.NodeContent content] } instance ResponseConsumer DeleteObjects DeleteObjectsResponse where type ResponseMetadata DeleteObjectsResponse = S3Metadata responseConsumer _ = s3XmlResponseConsumer parse where parse cursor = do dorDeleted <- sequence $ cursor $/ Cu.laxElement "Deleted" &| parseDeleted dorErrors <- sequence $ cursor $/ Cu.laxElement "Error" &| parseErrors return DeleteObjectsResponse {..} parseDeleted c = do ddKey <- force "Missing Key" $ c $/ elContent "Key" let ddVersionId = listToMaybe $ c $/ elContent "VersionId" ddDeleteMarkerVersionId = listToMaybe $ c $/ elContent "DeleteMarkerVersionId" return DORDeleted {..} parseErrors c = do deKey <- force "Missing Key" $ c $/ elContent "Key" deCode <- force "Missing Code" $ c $/ elContent "Code" deMessage <- force "Missing Message" $ c $/ elContent "Message" return DORErrors {..} instance Transaction DeleteObjects DeleteObjectsResponse instance AsMemoryResponse DeleteObjectsResponse where type MemoryResponse DeleteObjectsResponse = DeleteObjectsResponse loadToMemory = return aws-0.13.0/Aws/S3/Commands/CopyObject.hs0000644000000000000000000001301012615132266015727 0ustar0000000000000000{-# LANGUAGE CPP #-} module Aws.S3.Commands.CopyObject where import Aws.Core import Aws.S3.Core import Control.Applicative import Control.Arrow (second) import Control.Monad.Trans.Resource (throwM) import qualified Data.ByteString as B import qualified Data.CaseInsensitive as CI import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time import qualified Network.HTTP.Conduit as HTTP import Text.XML.Cursor (($/), (&|)) #if MIN_VERSION_time(1,5,0) import Data.Time.Format #else import System.Locale #endif data CopyMetadataDirective = CopyMetadata | ReplaceMetadata [(T.Text,T.Text)] deriving (Show) data CopyObject = CopyObject { coObjectName :: T.Text , coBucket :: Bucket , coSource :: ObjectId , coMetadataDirective :: CopyMetadataDirective , coIfMatch :: Maybe T.Text , coIfNoneMatch :: Maybe T.Text , coIfUnmodifiedSince :: Maybe UTCTime , coIfModifiedSince :: Maybe UTCTime , coStorageClass :: Maybe StorageClass , coAcl :: Maybe CannedAcl , coContentType :: Maybe B.ByteString } deriving (Show) copyObject :: Bucket -> T.Text -> ObjectId -> CopyMetadataDirective -> CopyObject copyObject bucket obj src meta = CopyObject obj bucket src meta Nothing Nothing Nothing Nothing Nothing Nothing Nothing data CopyObjectResponse = CopyObjectResponse { corVersionId :: Maybe T.Text , corLastModified :: UTCTime , corETag :: T.Text } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery CopyObject where type ServiceConfiguration CopyObject = S3Configuration signQuery CopyObject {..} = s3SignQuery S3Query { s3QMethod = Put , s3QBucket = Just $ T.encodeUtf8 coBucket , s3QObject = Just $ T.encodeUtf8 coObjectName , s3QSubresources = [] , s3QQuery = [] , s3QContentType = coContentType , s3QContentMd5 = Nothing , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [ Just ("x-amz-copy-source", oidBucket `T.append` "/" `T.append` oidObject `T.append` case oidVersion of Nothing -> T.empty Just v -> "?versionId=" `T.append` v) , Just ("x-amz-metadata-directive", case coMetadataDirective of CopyMetadata -> "COPY" ReplaceMetadata _ -> "REPLACE") , ("x-amz-copy-source-if-match",) <$> coIfMatch , ("x-amz-copy-source-if-none-match",) <$> coIfNoneMatch , ("x-amz-copy-source-if-unmodified-since",) <$> textHttpDate <$> coIfUnmodifiedSince , ("x-amz-copy-source-if-modified-since",) <$> textHttpDate <$> coIfModifiedSince , ("x-amz-acl",) <$> writeCannedAcl <$> coAcl , ("x-amz-storage-class",) <$> writeStorageClass <$> coStorageClass ] ++ map ( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) coMetadata , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [] , s3QRequestBody = Nothing } where coMetadata = case coMetadataDirective of CopyMetadata -> [] ReplaceMetadata xs -> xs ObjectId{..} = coSource instance ResponseConsumer CopyObject CopyObjectResponse where type ResponseMetadata CopyObjectResponse = S3Metadata responseConsumer _ mref = flip s3ResponseConsumer mref $ \resp -> do let vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp) (lastMod, etag) <- xmlCursorConsumer parse mref resp return $ CopyObjectResponse vid lastMod etag where parse el = do let parseHttpDate' x = case parseTime defaultTimeLocale iso8601UtcDate x of Nothing -> throwM $ XmlException ("Invalid Last-Modified " ++ x) Just y -> return y lastMod <- forceM "Missing Last-Modified" $ el $/ elContent "LastModified" &| (parseHttpDate' . T.unpack) etag <- force "Missing ETag" $ el $/ elContent "ETag" return (lastMod, etag) instance Transaction CopyObject CopyObjectResponse instance AsMemoryResponse CopyObjectResponse where type MemoryResponse CopyObjectResponse = CopyObjectResponse loadToMemory = return aws-0.13.0/Aws/S3/Commands/GetObject.hs0000644000000000000000000001024012615132266015536 0ustar0000000000000000module Aws.S3.Commands.GetObject where import Aws.Core import Aws.S3.Core import Control.Applicative import Control.Monad.Trans.Resource (ResourceT) import Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP data GetObject = GetObject { goBucket :: Bucket , goObjectName :: Object , goVersionId :: Maybe T.Text , goResponseContentType :: Maybe T.Text , goResponseContentLanguage :: Maybe T.Text , goResponseExpires :: Maybe T.Text , goResponseCacheControl :: Maybe T.Text , goResponseContentDisposition :: Maybe T.Text , goResponseContentEncoding :: Maybe T.Text , goResponseContentRange :: Maybe (Int,Int) } deriving (Show) getObject :: Bucket -> T.Text -> GetObject getObject b o = GetObject b o Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing data GetObjectResponse = GetObjectResponse { gorMetadata :: ObjectMetadata, gorResponse :: HTTP.Response (C.ResumableSource (ResourceT IO) B8.ByteString) } data GetObjectMemoryResponse = GetObjectMemoryResponse ObjectMetadata (HTTP.Response L.ByteString) deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery GetObject where type ServiceConfiguration GetObject = S3Configuration signQuery GetObject {..} = s3SignQuery S3Query { s3QMethod = Get , s3QBucket = Just $ T.encodeUtf8 goBucket , s3QObject = Just $ T.encodeUtf8 goObjectName , s3QSubresources = HTTP.toQuery [ ("versionId" :: B8.ByteString,) <$> goVersionId , ("response-content-type" :: B8.ByteString,) <$> goResponseContentType , ("response-content-language",) <$> goResponseContentLanguage , ("response-expires",) <$> goResponseExpires , ("response-cache-control",) <$> goResponseCacheControl , ("response-content-disposition",) <$> goResponseContentDisposition , ("response-content-encoding",) <$> goResponseContentEncoding ] , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = [] , s3QOtherHeaders = catMaybes [ decodeRange <$> goResponseContentRange ] , s3QRequestBody = Nothing } where decodeRange (pos,len) = ("range",B8.concat $ ["bytes=", B8.pack (show pos), "-", B8.pack (show len)]) instance ResponseConsumer GetObject GetObjectResponse where type ResponseMetadata GetObjectResponse = S3Metadata responseConsumer GetObject{..} metadata resp = do rsp <- s3BinaryResponseConsumer return metadata resp om <- parseObjectMetadata (HTTP.responseHeaders resp) return $ GetObjectResponse om rsp instance Transaction GetObject GetObjectResponse instance AsMemoryResponse GetObjectResponse where type MemoryResponse GetObjectResponse = GetObjectMemoryResponse loadToMemory (GetObjectResponse om x) = do bss <- HTTP.responseBody x C.$$+- CL.consume return $ GetObjectMemoryResponse om x { HTTP.responseBody = L.fromChunks bss } aws-0.13.0/Aws/S3/Commands/PutBucket.hs0000644000000000000000000001005712615132266015604 0ustar0000000000000000module Aws.S3.Commands.PutBucket where import Aws.Core import Aws.S3.Core import Control.Monad import Data.Maybe import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Conduit as HTTP import qualified Text.XML as XML data PutBucket = PutBucket { pbBucket :: Bucket , pbCannedAcl :: Maybe CannedAcl , pbLocationConstraint :: LocationConstraint , pbXStorageClass :: Maybe StorageClass -- ^ Google Cloud Storage S3 nonstandard extension } deriving (Show) putBucket :: Bucket -> PutBucket putBucket bucket = PutBucket bucket Nothing locationUsClassic Nothing data PutBucketResponse = PutBucketResponse deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery PutBucket where type ServiceConfiguration PutBucket = S3Configuration signQuery PutBucket{..} = s3SignQuery (S3Query { s3QMethod = Put , s3QBucket = Just $ T.encodeUtf8 pbBucket , s3QSubresources = [] , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QObject = Nothing , s3QAmzHeaders = case pbCannedAcl of Nothing -> [] Just acl -> [("x-amz-acl", T.encodeUtf8 $ writeCannedAcl acl)] , s3QOtherHeaders = [] , s3QRequestBody = guard (not (null elts)) >> (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def) XML.Document { XML.documentPrologue = XML.Prologue [] Nothing [] , XML.documentRoot = root , XML.documentEpilogue = [] } }) where root = XML.Element { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}CreateBucketConfiguration" , XML.elementAttributes = M.empty , XML.elementNodes = elts } elts = catMaybes [ if T.null pbLocationConstraint then Nothing else Just (locationconstraint pbLocationConstraint) , fmap storageclass pbXStorageClass ] locationconstraint c = XML.NodeElement (XML.Element { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}LocationConstraint" , XML.elementAttributes = M.empty , XML.elementNodes = [XML.NodeContent c] }) storageclass c = XML.NodeElement (XML.Element { XML.elementName = "StorageClass" , XML.elementAttributes = M.empty , XML.elementNodes = [XML.NodeContent (writeStorageClass c)] }) instance ResponseConsumer r PutBucketResponse where type ResponseMetadata PutBucketResponse = S3Metadata responseConsumer _ = s3ResponseConsumer $ \_ -> return PutBucketResponse instance Transaction PutBucket PutBucketResponse instance AsMemoryResponse PutBucketResponse where type MemoryResponse PutBucketResponse = PutBucketResponse loadToMemory = return aws-0.13.0/Aws/S3/Commands/GetBucketLocation.hs0000644000000000000000000000430212615132266017240 0ustar0000000000000000module Aws.S3.Commands.GetBucketLocation where import Aws.Core import Aws.S3.Core import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Types as HTTP import Text.XML.Cursor (($.//)) data GetBucketLocation = GetBucketLocation { gblBucket :: Bucket } deriving Show getBucketLocation :: Bucket -> GetBucketLocation getBucketLocation bucket = GetBucketLocation { gblBucket = bucket } data GetBucketLocationResponse = GetBucketLocationResponse { gblrLocationConstraint :: LocationConstraint } deriving Show instance SignQuery GetBucketLocation where type ServiceConfiguration GetBucketLocation = S3Configuration signQuery GetBucketLocation {..} = s3SignQuery S3Query { s3QMethod = Get , s3QBucket = Just $ T.encodeUtf8 gblBucket , s3QObject = Nothing , s3QSubresources = [("location" :: B8.ByteString, Nothing :: Maybe B8.ByteString)] , s3QQuery = HTTP.toQuery ([] :: [(B8.ByteString, T.Text)]) , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = [] , s3QOtherHeaders = [] , s3QRequestBody = Nothing } instance ResponseConsumer r GetBucketLocationResponse where type ResponseMetadata GetBucketLocationResponse = S3Metadata responseConsumer _ = s3XmlResponseConsumer parse where parse cursor = do locationConstraint <- force "Missing Location" $ cursor $.// elContent "LocationConstraint" return GetBucketLocationResponse { gblrLocationConstraint = normaliseLocation locationConstraint } instance Transaction GetBucketLocation GetBucketLocationResponse instance AsMemoryResponse GetBucketLocationResponse where type MemoryResponse GetBucketLocationResponse = GetBucketLocationResponse loadToMemory = return aws-0.13.0/Aws/S3/Commands/DeleteObject.hs0000644000000000000000000000313012615132266016221 0ustar0000000000000000module Aws.S3.Commands.DeleteObject where import Aws.Core import Aws.S3.Core import Data.ByteString.Char8 ({- IsString -}) import qualified Data.Text as T import qualified Data.Text.Encoding as T data DeleteObject = DeleteObject { doObjectName :: T.Text, doBucket :: Bucket } data DeleteObjectResponse = DeleteObjectResponse{ } -- | ServiceConfiguration: 'S3Configuration' instance SignQuery DeleteObject where type ServiceConfiguration DeleteObject = S3Configuration signQuery DeleteObject {..} = s3SignQuery S3Query { s3QMethod = Delete , s3QBucket = Just $ T.encodeUtf8 doBucket , s3QSubresources = [] , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = [] , s3QOtherHeaders = [] , s3QRequestBody = Nothing , s3QObject = Just $ T.encodeUtf8 doObjectName } instance ResponseConsumer DeleteObject DeleteObjectResponse where type ResponseMetadata DeleteObjectResponse = S3Metadata responseConsumer _ = s3ResponseConsumer $ \_ -> return DeleteObjectResponse instance Transaction DeleteObject DeleteObjectResponse instance AsMemoryResponse DeleteObjectResponse where type MemoryResponse DeleteObjectResponse = DeleteObjectResponse loadToMemory = return aws-0.13.0/Aws/S3/Commands/Multipart.hs0000644000000000000000000004256312615132266015666 0ustar0000000000000000module Aws.S3.Commands.Multipart where import Aws.Aws import Aws.Core import Aws.S3.Core import Control.Applicative import Control.Arrow (second) import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Crypto.Hash import Data.ByteString.Char8 ({- IsString -}) import Data.Conduit import qualified Data.Conduit.List as CL import Data.Maybe import Text.XML.Cursor (($/)) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import qualified Text.XML as XML {- Aws supports following 6 api for Multipart-Upload. Currently this code does not support number 3 and 6. 1. Initiate Multipart Upload 2. Upload Part 3. Upload Part - Copy 4. Complete Multipart Upload 5. Abort Multipart Upload 6. List Parts -} data InitiateMultipartUpload = InitiateMultipartUpload { imuBucket :: Bucket , imuObjectName :: Object , imuCacheControl :: Maybe T.Text , imuContentDisposition :: Maybe T.Text , imuContentEncoding :: Maybe T.Text , imuContentType :: Maybe T.Text , imuExpires :: Maybe Int , imuMetadata :: [(T.Text,T.Text)] , imuStorageClass :: Maybe StorageClass , imuWebsiteRedirectLocation :: Maybe T.Text , imuAcl :: Maybe CannedAcl , imuServerSideEncryption :: Maybe ServerSideEncryption , imuAutoMakeBucket :: Bool -- ^ Internet Archive S3 nonstandard extension } deriving (Show) postInitiateMultipartUpload :: Bucket -> T.Text -> InitiateMultipartUpload postInitiateMultipartUpload b o = InitiateMultipartUpload b o Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing Nothing Nothing False data InitiateMultipartUploadResponse = InitiateMultipartUploadResponse { imurBucket :: !Bucket , imurKey :: !T.Text , imurUploadId :: !T.Text } -- | ServiceConfiguration: 'S3Configuration' instance SignQuery InitiateMultipartUpload where type ServiceConfiguration InitiateMultipartUpload = S3Configuration signQuery InitiateMultipartUpload {..} = s3SignQuery S3Query { s3QMethod = Post , s3QBucket = Just $ T.encodeUtf8 imuBucket , s3QObject = Just $ T.encodeUtf8 $ imuObjectName , s3QSubresources = HTTP.toQuery[ ("uploads" :: B8.ByteString , Nothing :: Maybe B8.ByteString)] , s3QQuery = [] , s3QContentType = T.encodeUtf8 <$> imuContentType , s3QContentMd5 = Nothing , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [ ("x-amz-acl",) <$> writeCannedAcl <$> imuAcl , ("x-amz-storage-class",) <$> writeStorageClass <$> imuStorageClass , ("x-amz-website-redirect-location",) <$> imuWebsiteRedirectLocation , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> imuServerSideEncryption , if imuAutoMakeBucket then Just ("x-amz-auto-make-bucket", "1") else Nothing ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) imuMetadata , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [ ("Expires",) . T.pack . show <$> imuExpires , ("Cache-Control",) <$> imuCacheControl , ("Content-Disposition",) <$> imuContentDisposition , ("Content-Encoding",) <$> imuContentEncoding ] , s3QRequestBody = Nothing } instance ResponseConsumer r InitiateMultipartUploadResponse where type ResponseMetadata InitiateMultipartUploadResponse = S3Metadata responseConsumer _ = s3XmlResponseConsumer parse where parse cursor = do bucket <- force "Missing Bucket Name" $ cursor $/ elContent "Bucket" key <- force "Missing Key" $ cursor $/ elContent "Key" uploadId <- force "Missing UploadID" $ cursor $/ elContent "UploadId" return InitiateMultipartUploadResponse{ imurBucket = bucket , imurKey = key , imurUploadId = uploadId } instance Transaction InitiateMultipartUpload InitiateMultipartUploadResponse instance AsMemoryResponse InitiateMultipartUploadResponse where type MemoryResponse InitiateMultipartUploadResponse = InitiateMultipartUploadResponse loadToMemory = return ---------------------------------- data UploadPart = UploadPart { upObjectName :: T.Text , upBucket :: Bucket , upPartNumber :: Integer , upUploadId :: T.Text , upContentType :: Maybe B8.ByteString , upContentMD5 :: Maybe (Digest MD5) , upServerSideEncryption :: Maybe ServerSideEncryption , upRequestBody :: HTTP.RequestBody , upExpect100Continue :: Bool -- ^ Note: Requires http-client >= 0.4.10 } uploadPart :: Bucket -> T.Text -> Integer -> T.Text -> HTTP.RequestBody -> UploadPart uploadPart bucket obj p i body = UploadPart obj bucket p i Nothing Nothing Nothing body False data UploadPartResponse = UploadPartResponse { uprVersionId :: !(Maybe T.Text), uprETag :: !T.Text } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery UploadPart where type ServiceConfiguration UploadPart = S3Configuration signQuery UploadPart {..} = s3SignQuery S3Query { s3QMethod = Put , s3QBucket = Just $ T.encodeUtf8 upBucket , s3QObject = Just $ T.encodeUtf8 upObjectName , s3QSubresources = HTTP.toQuery[ ("partNumber" :: B8.ByteString , Just (T.pack (show upPartNumber)) :: Maybe T.Text) , ("uploadId" :: B8.ByteString, Just upUploadId :: Maybe T.Text) ] , s3QQuery = [] , s3QContentType = upContentType , s3QContentMd5 = upContentMD5 , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [ ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> upServerSideEncryption ] , s3QOtherHeaders = catMaybes [ if upExpect100Continue then Just ("Expect", "100-continue") else Nothing ] , s3QRequestBody = Just upRequestBody } instance ResponseConsumer UploadPart UploadPartResponse where type ResponseMetadata UploadPartResponse = S3Metadata responseConsumer _ = s3ResponseConsumer $ \resp -> do let vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp) let etag = fromMaybe "" $ T.decodeUtf8 `fmap` lookup "ETag" (HTTP.responseHeaders resp) return $ UploadPartResponse vid etag instance Transaction UploadPart UploadPartResponse instance AsMemoryResponse UploadPartResponse where type MemoryResponse UploadPartResponse = UploadPartResponse loadToMemory = return ---------------------------- data CompleteMultipartUpload = CompleteMultipartUpload { cmuBucket :: Bucket , cmuObjectName :: Object , cmuUploadId :: T.Text , cmuPartNumberAndEtags :: [(Integer,T.Text)] , cmuExpiration :: Maybe T.Text , cmuServerSideEncryption :: Maybe T.Text , cmuServerSideEncryptionCustomerAlgorithm :: Maybe T.Text , cmuVersionId :: Maybe T.Text } deriving (Show) postCompleteMultipartUpload :: Bucket -> T.Text -> T.Text -> [(Integer,T.Text)]-> CompleteMultipartUpload postCompleteMultipartUpload b o i p = CompleteMultipartUpload b o i p Nothing Nothing Nothing Nothing data CompleteMultipartUploadResponse = CompleteMultipartUploadResponse { cmurLocation :: !T.Text , cmurBucket :: !Bucket , cmurKey :: !T.Text , cmurETag :: !T.Text } -- | ServiceConfiguration: 'S3Configuration' instance SignQuery CompleteMultipartUpload where type ServiceConfiguration CompleteMultipartUpload = S3Configuration signQuery CompleteMultipartUpload {..} = s3SignQuery S3Query { s3QMethod = Post , s3QBucket = Just $ T.encodeUtf8 cmuBucket , s3QObject = Just $ T.encodeUtf8 cmuObjectName , s3QSubresources = HTTP.toQuery[ ("uploadId" :: B8.ByteString, Just cmuUploadId :: Maybe T.Text) ] , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = catMaybes [ ("x-amz-expiration",) <$> (T.encodeUtf8 <$> cmuExpiration) , ("x-amz-server-side-encryption",) <$> (T.encodeUtf8 <$> cmuServerSideEncryption) , ("x-amz-server-side-encryption-customer-algorithm",) <$> (T.encodeUtf8 <$> cmuServerSideEncryptionCustomerAlgorithm) , ("x-amz-version-id",) <$> (T.encodeUtf8 <$> cmuVersionId) ] , s3QOtherHeaders = [] , s3QRequestBody = Just $ HTTP.RequestBodyLBS reqBody } where reqBody = XML.renderLBS XML.def XML.Document { XML.documentPrologue = XML.Prologue [] Nothing [] , XML.documentRoot = root , XML.documentEpilogue = [] } root = XML.Element { XML.elementName = "CompleteMultipartUpload" , XML.elementAttributes = M.empty , XML.elementNodes = (partNode <$> cmuPartNumberAndEtags) } partNode (partNumber, etag) = XML.NodeElement XML.Element { XML.elementName = "Part" , XML.elementAttributes = M.empty , XML.elementNodes = [keyNode (T.pack (show partNumber)),etagNode etag] } etagNode = toNode "ETag" keyNode = toNode "PartNumber" toNode name content = XML.NodeElement XML.Element { XML.elementName = name , XML.elementAttributes = M.empty , XML.elementNodes = [XML.NodeContent content] } instance ResponseConsumer r CompleteMultipartUploadResponse where type ResponseMetadata CompleteMultipartUploadResponse = S3Metadata responseConsumer _ = s3XmlResponseConsumer parse where parse cursor = do location <- force "Missing Location" $ cursor $/ elContent "Location" bucket <- force "Missing Bucket Name" $ cursor $/ elContent "Bucket" key <- force "Missing Key" $ cursor $/ elContent "Key" etag <- force "Missing ETag" $ cursor $/ elContent "ETag" return CompleteMultipartUploadResponse{ cmurLocation = location , cmurBucket = bucket , cmurKey = key , cmurETag = etag } instance Transaction CompleteMultipartUpload CompleteMultipartUploadResponse instance AsMemoryResponse CompleteMultipartUploadResponse where type MemoryResponse CompleteMultipartUploadResponse = CompleteMultipartUploadResponse loadToMemory = return ---------------------------- data AbortMultipartUpload = AbortMultipartUpload { amuBucket :: Bucket , amuObjectName :: Object , amuUploadId :: T.Text } deriving (Show) postAbortMultipartUpload :: Bucket -> T.Text -> T.Text -> AbortMultipartUpload postAbortMultipartUpload b o i = AbortMultipartUpload b o i data AbortMultipartUploadResponse = AbortMultipartUploadResponse { } -- | ServiceConfiguration: 'S3Configuration' instance SignQuery AbortMultipartUpload where type ServiceConfiguration AbortMultipartUpload = S3Configuration signQuery AbortMultipartUpload {..} = s3SignQuery S3Query { s3QMethod = Delete , s3QBucket = Just $ T.encodeUtf8 amuBucket , s3QObject = Just $ T.encodeUtf8 amuObjectName , s3QSubresources = HTTP.toQuery[ ("uploadId" :: B8.ByteString, Just amuUploadId :: Maybe T.Text) ] , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = [] , s3QOtherHeaders = [] , s3QRequestBody = Nothing } instance ResponseConsumer r AbortMultipartUploadResponse where type ResponseMetadata AbortMultipartUploadResponse = S3Metadata responseConsumer _ = s3XmlResponseConsumer parse where parse _cursor = return AbortMultipartUploadResponse {} instance Transaction AbortMultipartUpload AbortMultipartUploadResponse instance AsMemoryResponse AbortMultipartUploadResponse where type MemoryResponse AbortMultipartUploadResponse = AbortMultipartUploadResponse loadToMemory = return ---------------------------- getUploadId :: Configuration -> S3Configuration NormalQuery -> HTTP.Manager -> T.Text -> T.Text -> IO T.Text getUploadId cfg s3cfg mgr bucket object = do InitiateMultipartUploadResponse { imurBucket = _bucket , imurKey = _object' , imurUploadId = uploadId } <- memoryAws cfg s3cfg mgr $ postInitiateMultipartUpload bucket object return uploadId sendEtag :: Configuration -> S3Configuration NormalQuery -> HTTP.Manager -> T.Text -> T.Text -> T.Text -> [T.Text] -> IO () sendEtag cfg s3cfg mgr bucket object uploadId etags = do _ <- memoryAws cfg s3cfg mgr $ postCompleteMultipartUpload bucket object uploadId (zip [1..] etags) return () putConduit :: MonadResource m => Configuration -> S3Configuration NormalQuery -> HTTP.Manager -> T.Text -> T.Text -> T.Text -> Conduit BL.ByteString m T.Text putConduit cfg s3cfg mgr bucket object uploadId = loop 1 where loop n = do v' <- await case v' of Just v -> do UploadPartResponse _ etag <- memoryAws cfg s3cfg mgr $ uploadPart bucket object n uploadId (HTTP.RequestBodyLBS v) yield etag loop (n+1) Nothing -> return () chunkedConduit :: (MonadResource m) => Integer -> Conduit B8.ByteString m BL.ByteString chunkedConduit size = loop 0 [] where loop :: Monad m => Integer -> [B8.ByteString] -> Conduit B8.ByteString m BL.ByteString loop cnt str = await >>= maybe (yieldChunk str) go where go :: Monad m => B8.ByteString -> Conduit B8.ByteString m BL.ByteString go line | size <= len = yieldChunk newStr >> loop 0 [] | otherwise = loop len newStr where len = fromIntegral (B8.length line) + cnt newStr = line:str yieldChunk :: Monad m => [B8.ByteString] -> Conduit i m BL.ByteString yieldChunk = yield . BL.fromChunks . reverse multipartUpload :: Configuration -> S3Configuration NormalQuery -> HTTP.Manager -> T.Text -> T.Text -> Conduit () (ResourceT IO) B8.ByteString -> Integer -> ResourceT IO () multipartUpload cfg s3cfg mgr bucket object src chunkSize = do uploadId <- liftIO $ getUploadId cfg s3cfg mgr bucket object etags <- src $= chunkedConduit chunkSize $= putConduit cfg s3cfg mgr bucket object uploadId $$ CL.consume liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags multipartUploadSink :: MonadResource m => Configuration -> S3Configuration NormalQuery -> HTTP.Manager -> T.Text -- ^ Bucket name -> T.Text -- ^ Object name -> Integer -- ^ chunkSize (minimum: 5MB) -> Sink B8.ByteString m () multipartUploadSink cfg s3cfg = multipartUploadSinkWithInitiator cfg s3cfg postInitiateMultipartUpload multipartUploadWithInitiator :: Configuration -> S3Configuration NormalQuery -> (Bucket -> T.Text -> InitiateMultipartUpload) -> HTTP.Manager -> T.Text -> T.Text -> Conduit () (ResourceT IO) B8.ByteString -> Integer -> ResourceT IO () multipartUploadWithInitiator cfg s3cfg initiator mgr bucket object src chunkSize = do uploadId <- liftIO $ imurUploadId <$> memoryAws cfg s3cfg mgr (initiator bucket object) etags <- src $= chunkedConduit chunkSize $= putConduit cfg s3cfg mgr bucket object uploadId $$ CL.consume liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags multipartUploadSinkWithInitiator :: MonadResource m => Configuration -> S3Configuration NormalQuery -> (Bucket -> T.Text -> InitiateMultipartUpload) -- ^ Initiator -> HTTP.Manager -> T.Text -- ^ Bucket name -> T.Text -- ^ Object name -> Integer -- ^ chunkSize (minimum: 5MB) -> Sink B8.ByteString m () multipartUploadSinkWithInitiator cfg s3cfg initiator mgr bucket object chunkSize = do uploadId <- liftIO $ imurUploadId <$> memoryAws cfg s3cfg mgr (initiator bucket object) etags <- chunkedConduit chunkSize $= putConduit cfg s3cfg mgr bucket object uploadId $= CL.consume liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags aws-0.13.0/Aws/S3/Commands/GetService.hs0000644000000000000000000000456612615132266015746 0ustar0000000000000000{-# LANGUAGE CPP #-} module Aws.S3.Commands.GetService where import Aws.Core import Aws.S3.Core import Data.Maybe import Data.Time.Format #if MIN_VERSION_time(1,5,0) import Data.Time.Format #else import System.Locale #endif import Text.XML.Cursor (($/), ($//), (&|)) import qualified Data.Text as T import qualified Text.XML.Cursor as Cu data GetService = GetService data GetServiceResponse = GetServiceResponse { gsrOwner :: UserInfo , gsrBuckets :: [BucketInfo] } deriving (Show) instance ResponseConsumer r GetServiceResponse where type ResponseMetadata GetServiceResponse = S3Metadata responseConsumer _ = s3XmlResponseConsumer parse where parse el = do owner <- forceM "Missing Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo buckets <- sequence $ el $// Cu.laxElement "Bucket" &| parseBucket return GetServiceResponse { gsrOwner = owner, gsrBuckets = buckets } parseBucket el = do name <- force "Missing owner Name" $ el $/ elContent "Name" creationDateString <- force "Missing owner CreationDate" $ el $/ elContent "CreationDate" &| T.unpack creationDate <- force "Invalid CreationDate" . maybeToList $ parseTime defaultTimeLocale iso8601UtcDate creationDateString return BucketInfo { bucketName = name, bucketCreationDate = creationDate } -- | ServiceConfiguration: 'S3Configuration' instance SignQuery GetService where type ServiceConfiguration GetService = S3Configuration signQuery GetService = s3SignQuery S3Query { s3QMethod = Get , s3QBucket = Nothing , s3QObject = Nothing , s3QSubresources = [] , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = [] , s3QOtherHeaders = [] , s3QRequestBody = Nothing } instance Transaction GetService GetServiceResponse instance AsMemoryResponse GetServiceResponse where type MemoryResponse GetServiceResponse = GetServiceResponse loadToMemory = returnaws-0.13.0/Aws/S3/Commands/GetBucket.hs0000644000000000000000000001205012615132266015546 0ustar0000000000000000module Aws.S3.Commands.GetBucket where import Aws.Core import Aws.S3.Core import Control.Applicative import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe import Text.XML.Cursor (($/), (&|), (&//)) import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Traversable import qualified Network.HTTP.Types as HTTP import qualified Text.XML.Cursor as Cu data GetBucket = GetBucket { gbBucket :: Bucket , gbDelimiter :: Maybe T.Text , gbMarker :: Maybe T.Text , gbMaxKeys :: Maybe Int , gbPrefix :: Maybe T.Text } deriving (Show) getBucket :: Bucket -> GetBucket getBucket bucket = GetBucket { gbBucket = bucket , gbDelimiter = Nothing , gbMarker = Nothing , gbMaxKeys = Nothing , gbPrefix = Nothing } data GetBucketResponse = GetBucketResponse { gbrName :: Bucket , gbrDelimiter :: Maybe T.Text , gbrMarker :: Maybe T.Text , gbrMaxKeys :: Maybe Int , gbrPrefix :: Maybe T.Text , gbrContents :: [ObjectInfo] , gbrCommonPrefixes :: [T.Text] , gbrIsTruncated :: Bool , gbrNextMarker :: Maybe T.Text } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery GetBucket where type ServiceConfiguration GetBucket = S3Configuration signQuery GetBucket {..} = s3SignQuery S3Query { s3QMethod = Get , s3QBucket = Just $ T.encodeUtf8 gbBucket , s3QObject = Nothing , s3QSubresources = [] , s3QQuery = HTTP.toQuery [ ("delimiter" :: B8.ByteString ,) <$> gbDelimiter , ("marker",) <$> gbMarker , ("max-keys",) . T.pack . show <$> gbMaxKeys , ("prefix",) <$> gbPrefix ] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = [] , s3QOtherHeaders = [] , s3QRequestBody = Nothing } instance ResponseConsumer r GetBucketResponse where type ResponseMetadata GetBucketResponse = S3Metadata responseConsumer _ = s3XmlResponseConsumer parse where parse cursor = do name <- force "Missing Name" $ cursor $/ elContent "Name" let delimiter = listToMaybe $ cursor $/ elContent "Delimiter" let marker = listToMaybe $ cursor $/ elContent "Marker" maxKeys <- Data.Traversable.sequence . listToMaybe $ cursor $/ elContent "MaxKeys" &| textReadInt let truncated = maybe True (/= "false") $ listToMaybe $ cursor $/ elContent "IsTruncated" let nextMarker = listToMaybe $ cursor $/ elContent "NextMarker" let prefix = listToMaybe $ cursor $/ elContent "Prefix" contents <- sequence $ cursor $/ Cu.laxElement "Contents" &| parseObjectInfo let commonPrefixes = cursor $/ Cu.laxElement "CommonPrefixes" &// Cu.content return GetBucketResponse{ gbrName = name , gbrDelimiter = delimiter , gbrMarker = marker , gbrMaxKeys = maxKeys , gbrPrefix = prefix , gbrContents = contents , gbrCommonPrefixes = commonPrefixes , gbrIsTruncated = truncated , gbrNextMarker = nextMarker } instance Transaction GetBucket GetBucketResponse instance IteratedTransaction GetBucket GetBucketResponse where nextIteratedRequest request response = case (gbrIsTruncated response, gbrNextMarker response, gbrContents response) of (True, Just marker, _ ) -> Just $ request { gbMarker = Just marker } (True, Nothing, contents@(_:_)) -> Just $ request { gbMarker = Just $ objectKey $ last contents } (_, _, _ ) -> Nothing instance ListResponse GetBucketResponse ObjectInfo where listResponse = gbrContents instance AsMemoryResponse GetBucketResponse where type MemoryResponse GetBucketResponse = GetBucketResponse loadToMemory = return aws-0.13.0/Aws/S3/Commands/PutObject.hs0000644000000000000000000001056712615132266015603 0ustar0000000000000000{-# LANGUAGE CPP #-} module Aws.S3.Commands.PutObject where import Aws.Core import Aws.S3.Core import Control.Applicative import Control.Arrow (second) import Crypto.Hash import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe import qualified Data.ByteString.Char8 as B import qualified Data.CaseInsensitive as CI import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Conduit as HTTP data PutObject = PutObject { poObjectName :: T.Text, poBucket :: Bucket, poContentType :: Maybe B.ByteString, poCacheControl :: Maybe T.Text, poContentDisposition :: Maybe T.Text, poContentEncoding :: Maybe T.Text, poContentMD5 :: Maybe (Digest MD5), poExpires :: Maybe Int, poAcl :: Maybe CannedAcl, poStorageClass :: Maybe StorageClass, poWebsiteRedirectLocation :: Maybe T.Text, poServerSideEncryption :: Maybe ServerSideEncryption, #if MIN_VERSION_http_conduit(2, 0, 0) poRequestBody :: HTTP.RequestBody, #else poRequestBody :: HTTP.RequestBody (C.ResourceT IO), #endif poMetadata :: [(T.Text,T.Text)], poAutoMakeBucket :: Bool, -- ^ Internet Archive S3 nonstandard extension poExpect100Continue :: Bool -- ^ Note: Requires http-client >= 0.4.10 } #if MIN_VERSION_http_conduit(2, 0, 0) putObject :: Bucket -> T.Text -> HTTP.RequestBody -> PutObject #else putObject :: Bucket -> T.Text -> HTTP.RequestBody (C.ResourceT IO) -> PutObject #endif putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False False data PutObjectResponse = PutObjectResponse { porVersionId :: Maybe T.Text } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery PutObject where type ServiceConfiguration PutObject = S3Configuration signQuery PutObject {..} = s3SignQuery S3Query { s3QMethod = Put , s3QBucket = Just $ T.encodeUtf8 poBucket , s3QSubresources = [] , s3QQuery = [] , s3QContentType = poContentType , s3QContentMd5 = poContentMD5 , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [ ("x-amz-acl",) <$> writeCannedAcl <$> poAcl , ("x-amz-storage-class",) <$> writeStorageClass <$> poStorageClass , ("x-amz-website-redirect-location",) <$> poWebsiteRedirectLocation , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> poServerSideEncryption , if poAutoMakeBucket then Just ("x-amz-auto-make-bucket", "1") else Nothing ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) poMetadata , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [ ("Expires",) . T.pack . show <$> poExpires , ("Cache-Control",) <$> poCacheControl , ("Content-Disposition",) <$> poContentDisposition , ("Content-Encoding",) <$> poContentEncoding , if poExpect100Continue then Just ("Expect", "100-continue") else Nothing ] , s3QRequestBody = Just poRequestBody , s3QObject = Just $ T.encodeUtf8 poObjectName } instance ResponseConsumer PutObject PutObjectResponse where type ResponseMetadata PutObjectResponse = S3Metadata responseConsumer _ = s3ResponseConsumer $ \resp -> do let vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp) return $ PutObjectResponse vid instance Transaction PutObject PutObjectResponse instance AsMemoryResponse PutObjectResponse where type MemoryResponse PutObjectResponse = PutObjectResponse loadToMemory = return aws-0.13.0/Aws/S3/Commands/HeadObject.hs0000644000000000000000000000526312615132266015671 0ustar0000000000000000module Aws.S3.Commands.HeadObject where import Aws.Core import Aws.S3.Core import Control.Applicative import Control.Monad.Trans.Resource (throwM) import Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP data HeadObject = HeadObject { hoBucket :: Bucket , hoObjectName :: Object , hoVersionId :: Maybe T.Text } deriving (Show) headObject :: Bucket -> T.Text -> HeadObject headObject b o = HeadObject b o Nothing data HeadObjectResponse = HeadObjectResponse { horMetadata :: Maybe ObjectMetadata } data HeadObjectMemoryResponse = HeadObjectMemoryResponse (Maybe ObjectMetadata) deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery HeadObject where type ServiceConfiguration HeadObject = S3Configuration signQuery HeadObject {..} = s3SignQuery S3Query { s3QMethod = Head , s3QBucket = Just $ T.encodeUtf8 hoBucket , s3QObject = Just $ T.encodeUtf8 hoObjectName , s3QSubresources = HTTP.toQuery [ ("versionId" :: B8.ByteString,) <$> hoVersionId ] , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = [] , s3QOtherHeaders = [] , s3QRequestBody = Nothing } instance ResponseConsumer HeadObject HeadObjectResponse where type ResponseMetadata HeadObjectResponse = S3Metadata responseConsumer HeadObject{..} _ resp | status == HTTP.status200 = HeadObjectResponse . Just <$> parseObjectMetadata headers | status == HTTP.status404 = return $ HeadObjectResponse Nothing | otherwise = throwM $ HTTP.StatusCodeException status headers cookies where status = HTTP.responseStatus resp headers = HTTP.responseHeaders resp cookies = HTTP.responseCookieJar resp instance Transaction HeadObject HeadObjectResponse instance AsMemoryResponse HeadObjectResponse where type MemoryResponse HeadObjectResponse = HeadObjectMemoryResponse loadToMemory (HeadObjectResponse om) = return (HeadObjectMemoryResponse om) aws-0.13.0/Aws/S3/Commands/DeleteBucket.hs0000644000000000000000000000311312615132266016231 0ustar0000000000000000module Aws.S3.Commands.DeleteBucket where import Aws.Core import Aws.S3.Core import Data.ByteString.Char8 ({- IsString -}) import qualified Data.Text as T import qualified Data.Text.Encoding as T data DeleteBucket = DeleteBucket { dbBucket :: Bucket } deriving (Show) data DeleteBucketResponse = DeleteBucketResponse {} deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery DeleteBucket where type ServiceConfiguration DeleteBucket = S3Configuration signQuery DeleteBucket {..} = s3SignQuery S3Query { s3QMethod = Delete , s3QBucket = Just $ T.encodeUtf8 dbBucket , s3QSubresources = [] , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = [] , s3QOtherHeaders = [] , s3QRequestBody = Nothing , s3QObject = Nothing } instance ResponseConsumer DeleteBucket DeleteBucketResponse where type ResponseMetadata DeleteBucketResponse = S3Metadata responseConsumer _ = s3ResponseConsumer $ \_ -> return DeleteBucketResponse instance Transaction DeleteBucket DeleteBucketResponse instance AsMemoryResponse DeleteBucketResponse where type MemoryResponse DeleteBucketResponse = DeleteBucketResponse loadToMemory = return aws-0.13.0/Aws/Sqs/0000755000000000000000000000000012615132266012057 5ustar0000000000000000aws-0.13.0/Aws/Sqs/Commands.hs0000644000000000000000000000050012615132266014147 0ustar0000000000000000module Aws.Sqs.Commands ( module Aws.Sqs.Commands.Message, module Aws.Sqs.Commands.Permission, module Aws.Sqs.Commands.Queue, module Aws.Sqs.Commands.QueueAttributes ) where import Aws.Sqs.Commands.Message import Aws.Sqs.Commands.Permission import Aws.Sqs.Commands.Queue import Aws.Sqs.Commands.QueueAttributes aws-0.13.0/Aws/Sqs/Core.hs0000644000000000000000000003401512615132266013306 0ustar0000000000000000{-# LANGUAGE CPP #-} module Aws.Sqs.Core where import Aws.Core import Aws.S3.Core (LocationConstraint, locationUsClassic, locationUsWest, locationUsWest2, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationEu) import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (MonadThrow, throwM) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Conduit (($$+-)) import Data.IORef import Data.List import Data.Maybe import Data.Monoid import Data.Ord import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as TE import Data.Time import Data.Typeable import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP #if MIN_VERSION_time(1,5,0) import Data.Time.Format #else import System.Locale #endif import qualified Text.XML as XML import Text.XML.Cursor (($/)) import qualified Text.XML.Cursor as Cu type ErrorCode = T.Text data SqsError = SqsError { sqsStatusCode :: HTTP.Status , sqsErrorCode :: ErrorCode , sqsErrorType :: T.Text , sqsErrorMessage :: T.Text , sqsErrorDetail :: Maybe T.Text , sqsErrorMetadata :: Maybe SqsMetadata } | SqsXmlError { sqsXmlErrorMessage :: T.Text , sqsXmlErrorMetadata :: Maybe SqsMetadata } deriving (Show, Typeable) instance C.Exception SqsError data SqsMetadata = SqsMetadata { sqsMAmzId2 :: Maybe T.Text , sqsMRequestId :: Maybe T.Text } deriving (Show) instance Loggable SqsMetadata where toLogText (SqsMetadata id2 rid) = "SQS: request ID=" `mappend` fromMaybe "" rid `mappend` ", x-amz-id-2=" `mappend` fromMaybe "" id2 instance Monoid SqsMetadata where mempty = SqsMetadata Nothing Nothing SqsMetadata a1 r1 `mappend` SqsMetadata a2 r2 = SqsMetadata (a1 `mplus` a2) (r1 `mplus` r2) data SqsAuthorization = SqsAuthorizationHeader | SqsAuthorizationQuery deriving (Show) data Endpoint = Endpoint { endpointHost :: B.ByteString , endpointDefaultLocationConstraint :: LocationConstraint , endpointAllowedLocationConstraints :: [LocationConstraint] } deriving (Show) data SqsConfiguration qt = SqsConfiguration { sqsProtocol :: Protocol , sqsEndpoint :: Endpoint , sqsPort :: Int , sqsUseUri :: Bool , sqsDefaultExpiry :: NominalDiffTime } deriving (Show) instance DefaultServiceConfiguration (SqsConfiguration NormalQuery) where defServiceConfig = sqs HTTPS sqsEndpointUsClassic False debugServiceConfig = sqs HTTP sqsEndpointUsClassic False instance DefaultServiceConfiguration (SqsConfiguration UriOnlyQuery) where defServiceConfig = sqs HTTPS sqsEndpointUsClassic True debugServiceConfig = sqs HTTP sqsEndpointUsClassic True sqsEndpointUsClassic :: Endpoint sqsEndpointUsClassic = Endpoint { endpointHost = "queue.amazonaws.com" , endpointDefaultLocationConstraint = locationUsClassic , endpointAllowedLocationConstraints = [locationUsClassic , locationUsWest , locationEu , locationApSouthEast , locationApNorthEast] } sqsEndpointUsWest :: Endpoint sqsEndpointUsWest = Endpoint { endpointHost = "us-west-1.queue.amazonaws.com" , endpointDefaultLocationConstraint = locationUsWest , endpointAllowedLocationConstraints = [locationUsWest] } sqsEndpointUsWest2 :: Endpoint sqsEndpointUsWest2 = Endpoint { endpointHost = "us-west-2.queue.amazonaws.com" , endpointDefaultLocationConstraint = locationUsWest2 , endpointAllowedLocationConstraints = [locationUsWest2] } sqsEndpointEu :: Endpoint sqsEndpointEu = Endpoint { endpointHost = "eu-west-1.queue.amazonaws.com" , endpointDefaultLocationConstraint = locationEu , endpointAllowedLocationConstraints = [locationEu] } sqsEndpointApSouthEast :: Endpoint sqsEndpointApSouthEast = Endpoint { endpointHost = "ap-southeast-1.queue.amazonaws.com" , endpointDefaultLocationConstraint = locationApSouthEast , endpointAllowedLocationConstraints = [locationApSouthEast] } sqsEndpointApSouthEast2 :: Endpoint sqsEndpointApSouthEast2 = Endpoint { endpointHost = "sqs.ap-southeast-2.amazonaws.com" , endpointDefaultLocationConstraint = locationApSouthEast2 , endpointAllowedLocationConstraints = [locationApSouthEast2] } sqsEndpointApNorthEast :: Endpoint sqsEndpointApNorthEast = Endpoint { endpointHost = "sqs.ap-northeast-1.amazonaws.com" , endpointDefaultLocationConstraint = locationApNorthEast , endpointAllowedLocationConstraints = [locationApNorthEast] } sqs :: Protocol -> Endpoint -> Bool -> SqsConfiguration qt sqs protocol endpoint uri = SqsConfiguration { sqsProtocol = protocol , sqsEndpoint = endpoint , sqsPort = defaultPort protocol , sqsUseUri = uri , sqsDefaultExpiry = 15*60 } data SqsQuery = SqsQuery{ sqsQueueName :: Maybe QueueName, sqsQuery :: HTTP.Query } sqsSignQuery :: SqsQuery -> SqsConfiguration qt -> SignatureData -> SignedQuery sqsSignQuery SqsQuery{..} SqsConfiguration{..} SignatureData{..} = SignedQuery { sqMethod = method , sqProtocol = sqsProtocol , sqHost = endpointHost sqsEndpoint , sqPort = sqsPort , sqPath = path , sqQuery = signedQuery , sqDate = Just signatureTime , sqAuthorization = Nothing , sqBody = Nothing , sqStringToSign = stringToSign , sqContentType = Nothing , sqContentMd5 = Nothing , sqAmzHeaders = [] , sqOtherHeaders = [] } where method = PostQuery path = case sqsQueueName of Just x -> TE.encodeUtf8 $ printQueueName x Nothing -> "/" expandedQuery = sortBy (comparing fst) ( sqsQuery ++ [ ("AWSAccessKeyId", Just(accessKeyID signatureCredentials)), ("Expires", Just(BC.pack expiresString)), ("SignatureMethod", Just("HmacSHA256")), ("SignatureVersion",Just("2")), ("Version",Just("2012-11-05"))] ++ maybe [] (\tok -> [("SecurityToken", Just tok)]) (iamToken signatureCredentials)) expires = AbsoluteExpires $ sqsDefaultExpiry `addUTCTime` signatureTime expiresString = formatTime defaultTimeLocale "%FT%TZ" (fromAbsoluteTimeInfo expires) sig = signature signatureCredentials HmacSHA256 stringToSign stringToSign = Blaze.toByteString . mconcat . intersperse (Blaze8.fromChar '\n') . concat $ [[Blaze.copyByteString $ httpMethod method] , [Blaze.copyByteString $ endpointHost sqsEndpoint] , [Blaze.copyByteString path] , [Blaze.copyByteString $ HTTP.renderQuery False expandedQuery ]] signedQuery = expandedQuery ++ (HTTP.simpleQueryToQuery $ makeAuthQuery) makeAuthQuery = [("Signature", sig)] sqsResponseConsumer :: HTTPResponseConsumer a -> IORef SqsMetadata -> HTTPResponseConsumer a sqsResponseConsumer inner metadata resp = do let headerString = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp) let amzId2 = headerString "x-amz-id-2" let requestId = headerString "x-amz-request-id" let m = SqsMetadata { sqsMAmzId2 = amzId2, sqsMRequestId = requestId } liftIO $ tellMetadataRef metadata m if HTTP.responseStatus resp >= HTTP.status400 then sqsErrorResponseConsumer resp else inner resp sqsXmlResponseConsumer :: (Cu.Cursor -> Response SqsMetadata a) -> IORef SqsMetadata -> HTTPResponseConsumer a sqsXmlResponseConsumer parse metadataRef = sqsResponseConsumer (xmlCursorConsumer parse metadataRef) metadataRef sqsErrorResponseConsumer :: HTTPResponseConsumer a sqsErrorResponseConsumer resp = do doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def let cursor = Cu.fromDocument doc liftIO $ case parseError cursor of Right err -> throwM err Left otherErr -> throwM otherErr where parseError :: Cu.Cursor -> Either C.SomeException SqsError parseError root = do cursor <- force "Missing Error" $ root $/ Cu.laxElement "Error" code <- force "Missing error Code" $ cursor $/ elContent "Code" message <- force "Missing error Message" $ cursor $/ elContent "Message" errorType <- force "Missing error Type" $ cursor $/ elContent "Type" let detail = listToMaybe $ cursor $/ elContent "Detail" return SqsError { sqsStatusCode = HTTP.responseStatus resp , sqsErrorCode = code , sqsErrorMessage = message , sqsErrorType = errorType , sqsErrorDetail = detail , sqsErrorMetadata = Nothing } data QueueName = QueueName{ qName :: T.Text, qAccountNumber :: T.Text } deriving(Show, Read, Eq, Ord) printQueueName :: QueueName -> T.Text printQueueName queue = T.concat ["/", (qAccountNumber queue), "/", (qName queue), "/"] data QueueAttribute = QueueAll | ApproximateNumberOfMessages | ApproximateNumberOfMessagesNotVisible | VisibilityTimeout | CreatedTimestamp | LastModifiedTimestamp | Policy | MaximumMessageSize | MessageRetentionPeriod | QueueArn deriving(Show, Enum, Eq) data MessageAttribute = MessageAll -- ^ all values | SenderId -- ^ the AWS account number (or the IP address, if anonymous access is -- allowed) of the sender | SentTimestamp -- ^ the time when the message was sent (epoch time in milliseconds) | ApproximateReceiveCount -- ^ the number of times a message has been received but not deleted | ApproximateFirstReceiveTimestamp -- ^ the time when the message was first received (epoch time in -- milliseconds) deriving(Show,Read,Eq,Ord,Enum,Bounded) data SqsPermission = PermissionAll | PermissionSendMessage | PermissionReceiveMessage | PermissionDeleteMessage | PermissionChangeMessageVisibility | PermissionGetQueueAttributes deriving (Show, Enum, Eq) parseQueueAttribute :: MonadThrow m => T.Text -> m QueueAttribute parseQueueAttribute "ApproximateNumberOfMessages" = return ApproximateNumberOfMessages parseQueueAttribute "ApproximateNumberOfMessagesNotVisible" = return ApproximateNumberOfMessagesNotVisible parseQueueAttribute "VisibilityTimeout" = return VisibilityTimeout parseQueueAttribute "CreatedTimestamp" = return CreatedTimestamp parseQueueAttribute "LastModifiedTimestamp" = return LastModifiedTimestamp parseQueueAttribute "Policy" = return Policy parseQueueAttribute "MaximumMessageSize" = return MaximumMessageSize parseQueueAttribute "MessageRetentionPeriod" = return MessageRetentionPeriod parseQueueAttribute "QueueArn" = return QueueArn parseQueueAttribute x = throwM $ XmlException ( "Invalid Attribute Name. " ++ show x) printQueueAttribute :: QueueAttribute -> T.Text printQueueAttribute QueueAll = "All" printQueueAttribute ApproximateNumberOfMessages = "ApproximateNumberOfMessages" printQueueAttribute ApproximateNumberOfMessagesNotVisible = "ApproximateNumberOfMessagesNotVisible" printQueueAttribute VisibilityTimeout = "VisibilityTimeout" printQueueAttribute CreatedTimestamp = "CreatedTimestamp" printQueueAttribute LastModifiedTimestamp = "LastModifiedTimestamp" printQueueAttribute Policy = "Policy" printQueueAttribute MaximumMessageSize = "MaximumMessageSize" printQueueAttribute MessageRetentionPeriod = "MessageRetentionPeriod" printQueueAttribute QueueArn = "QueueArn" parseMessageAttribute :: MonadThrow m => T.Text -> m MessageAttribute parseMessageAttribute "SenderId" = return SenderId parseMessageAttribute "SentTimestamp" = return SentTimestamp parseMessageAttribute "ApproximateReceiveCount" = return ApproximateReceiveCount parseMessageAttribute "ApproximateFirstReceiveTimestamp" = return ApproximateFirstReceiveTimestamp parseMessageAttribute x = throwM $ XmlException ( "Invalid Attribute Name. " ++ show x) printMessageAttribute :: MessageAttribute -> T.Text printMessageAttribute MessageAll = "All" printMessageAttribute SenderId = "SenderId" printMessageAttribute SentTimestamp = "SentTimestamp" printMessageAttribute ApproximateReceiveCount = "ApproximateReceiveCount" printMessageAttribute ApproximateFirstReceiveTimestamp = "ApproximateFirstReceiveTimestamp" printPermission :: SqsPermission -> T.Text printPermission PermissionAll = "*" printPermission PermissionSendMessage = "SendMessage" printPermission PermissionReceiveMessage = "ReceiveMessage" printPermission PermissionDeleteMessage = "DeleteMessage" printPermission PermissionChangeMessageVisibility = "ChangeMessageVisibility" printPermission PermissionGetQueueAttributes = "GetQueueAttributes" newtype ReceiptHandle = ReceiptHandle T.Text deriving(Show, Read, Eq, Ord) newtype MessageId = MessageId T.Text deriving(Show, Read, Eq, Ord) printReceiptHandle :: ReceiptHandle -> T.Text printReceiptHandle (ReceiptHandle handle) = handle aws-0.13.0/Aws/Sqs/Commands/0000755000000000000000000000000012615132266013620 5ustar0000000000000000aws-0.13.0/Aws/Sqs/Commands/Queue.hs0000644000000000000000000001045112615132266015241 0ustar0000000000000000 module Aws.Sqs.Commands.Queue where import Aws.Core import Aws.Sqs.Core import Control.Applicative import Data.Maybe import Text.XML.Cursor (($//), (&/)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Text.XML.Cursor as Cu import qualified Data.ByteString.Char8 as B data CreateQueue = CreateQueue { cqDefaultVisibilityTimeout :: Maybe Int, cqQueueName :: T.Text } deriving (Show) data CreateQueueResponse = CreateQueueResponse { cqrQueueUrl :: T.Text } deriving (Show) instance ResponseConsumer r CreateQueueResponse where type ResponseMetadata CreateQueueResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse el = do url <- force "Missing Queue Url" $ el $// Cu.laxElement "QueueUrl" &/ Cu.content return CreateQueueResponse{ cqrQueueUrl = url} -- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery CreateQueue where type ServiceConfiguration CreateQueue = SqsConfiguration signQuery CreateQueue {..} = sqsSignQuery SqsQuery { sqsQueueName = Nothing, sqsQuery = [("Action", Just "CreateQueue"), ("QueueName", Just $ TE.encodeUtf8 cqQueueName)] ++ catMaybes [("DefaultVisibilityTimeout",) <$> case cqDefaultVisibilityTimeout of Just x -> Just $ Just $ B.pack $ show x Nothing -> Nothing]} instance Transaction CreateQueue CreateQueueResponse instance AsMemoryResponse CreateQueueResponse where type MemoryResponse CreateQueueResponse = CreateQueueResponse loadToMemory = return data DeleteQueue = DeleteQueue { dqQueueName :: QueueName } deriving (Show) data DeleteQueueResponse = DeleteQueueResponse deriving (Show) instance ResponseConsumer r DeleteQueueResponse where type ResponseMetadata DeleteQueueResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return DeleteQueueResponse{} -- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery DeleteQueue where type ServiceConfiguration DeleteQueue = SqsConfiguration signQuery DeleteQueue {..} = sqsSignQuery SqsQuery { sqsQueueName = Just dqQueueName, sqsQuery = [("Action", Just "DeleteQueue")]} instance Transaction DeleteQueue DeleteQueueResponse instance AsMemoryResponse DeleteQueueResponse where type MemoryResponse DeleteQueueResponse = DeleteQueueResponse loadToMemory = return data ListQueues = ListQueues { lqQueueNamePrefix :: Maybe T.Text } deriving (Show) data ListQueuesResponse = ListQueuesResponse { lqrQueueUrls :: [T.Text] } deriving (Show) instance ResponseConsumer r ListQueuesResponse where type ResponseMetadata ListQueuesResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse el = do let queues = el $// Cu.laxElement "QueueUrl" &/ Cu.content return ListQueuesResponse { lqrQueueUrls = queues } -- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery ListQueues where type ServiceConfiguration ListQueues = SqsConfiguration signQuery ListQueues{..} = sqsSignQuery SqsQuery { sqsQueueName = Nothing, sqsQuery = [("Action", Just "ListQueues")] ++ catMaybes [ ("QueueNamePrefix",) <$> case lqQueueNamePrefix of Just x -> Just $ Just $ TE.encodeUtf8 x Nothing -> Nothing]} instance Transaction ListQueues ListQueuesResponse instance AsMemoryResponse ListQueuesResponse where type MemoryResponse ListQueuesResponse = ListQueuesResponse loadToMemory = returnaws-0.13.0/Aws/Sqs/Commands/Permission.hs0000644000000000000000000000610312615132266016304 0ustar0000000000000000 module Aws.Sqs.Commands.Permission where import Aws.Core import Aws.Sqs.Core import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Network.HTTP.Types as HTTP data AddPermission = AddPermission { apLabel :: T.Text, apPermissions :: [(T.Text,SqsPermission)], apQueueName :: QueueName } deriving (Show) data AddPermissionResponse = AddPermissionResponse deriving (Show) formatPermissions :: [(T.Text,SqsPermission)] -> [HTTP.QueryItem] formatPermissions perms = concat $ zipWith(\ x y -> [(B.pack $ "AwsAccountId." ++ show y, Just $ B.pack $ T.unpack $ fst x), (B.pack $ "ActionName." ++ show y, Just $ B.pack $ T.unpack $ printPermission $ snd x)]) perms [1 :: Integer ..] instance ResponseConsumer r AddPermissionResponse where type ResponseMetadata AddPermissionResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return AddPermissionResponse {} -- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery AddPermission where type ServiceConfiguration AddPermission = SqsConfiguration signQuery AddPermission {..} = sqsSignQuery SqsQuery { sqsQueueName = Just apQueueName, sqsQuery = [("Action", Just "AddPermission"), ("QueueName", Just $ B.pack $ T.unpack $ printQueueName apQueueName), ("Label", Just $ B.pack $ T.unpack apLabel)] ++ formatPermissions apPermissions} instance Transaction AddPermission AddPermissionResponse instance AsMemoryResponse AddPermissionResponse where type MemoryResponse AddPermissionResponse = AddPermissionResponse loadToMemory = return data RemovePermission = RemovePermission { rpLabel :: T.Text, rpQueueName :: QueueName } deriving (Show) data RemovePermissionResponse = RemovePermissionResponse deriving (Show) instance ResponseConsumer r RemovePermissionResponse where type ResponseMetadata RemovePermissionResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return RemovePermissionResponse {} -- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery RemovePermission where type ServiceConfiguration RemovePermission = SqsConfiguration signQuery RemovePermission {..} = sqsSignQuery SqsQuery { sqsQueueName = Just rpQueueName, sqsQuery = [("Action", Just "RemovePermission"), ("Label", Just $ TE.encodeUtf8 rpLabel )]} instance Transaction RemovePermission RemovePermissionResponse instance AsMemoryResponse RemovePermissionResponse where type MemoryResponse RemovePermissionResponse = RemovePermissionResponse loadToMemory = returnaws-0.13.0/Aws/Sqs/Commands/QueueAttributes.hs0000644000000000000000000000722312615132266017313 0ustar0000000000000000 module Aws.Sqs.Commands.QueueAttributes where import Aws.Core import Aws.Sqs.Core import Text.XML.Cursor (($/), ($//), (&/), (&|)) import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Text.XML.Cursor as Cu data GetQueueAttributes = GetQueueAttributes { gqaQueueName :: QueueName, gqaAttributes :: [QueueAttribute] }deriving (Show) data GetQueueAttributesResponse = GetQueueAttributesResponse{ gqarAttributes :: [(QueueAttribute,T.Text)] } deriving (Show) parseAttributes :: Cu.Cursor -> [(QueueAttribute, T.Text)] parseAttributes el = do name <- force "Missing Name" $ el $/ Cu.laxElement "Name" &/ Cu.content value <- force "Missing Value" $ el $/ Cu.laxElement "Value" &/ Cu.content parsedName <- parseQueueAttribute name return (parsedName, value) instance ResponseConsumer r GetQueueAttributesResponse where type ResponseMetadata GetQueueAttributesResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse el = do let attributes = concat $ el $// Cu.laxElement "Attribute" &| parseAttributes return GetQueueAttributesResponse{ gqarAttributes = attributes } formatAttributes :: [QueueAttribute] -> [(B.ByteString, Maybe B.ByteString)] formatAttributes attrs = case length attrs of 0 -> undefined 1 -> [("AttributeName", Just $ B.pack $ T.unpack $ printQueueAttribute $ attrs !! 0)] _ -> zipWith (\ x y -> ((B.concat ["AttributeName.", B.pack $ show $ y]), Just $ B.pack $ T.unpack $ printQueueAttribute x) ) attrs [1 :: Integer ..] -- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery GetQueueAttributes where type ServiceConfiguration GetQueueAttributes = SqsConfiguration signQuery GetQueueAttributes{..} = sqsSignQuery SqsQuery { sqsQueueName = Just gqaQueueName, sqsQuery = [("Action", Just "GetQueueAttributes")] ++ (formatAttributes gqaAttributes)} instance Transaction GetQueueAttributes GetQueueAttributesResponse instance AsMemoryResponse GetQueueAttributesResponse where type MemoryResponse GetQueueAttributesResponse = GetQueueAttributesResponse loadToMemory = return data SetQueueAttributes = SetQueueAttributes{ sqaAttribute :: QueueAttribute, sqaValue :: T.Text, sqaQueueName :: QueueName }deriving (Show) data SetQueueAttributesResponse = SetQueueAttributesResponse{ } deriving (Show) instance ResponseConsumer r SetQueueAttributesResponse where type ResponseMetadata SetQueueAttributesResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return SetQueueAttributesResponse {} -- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery SetQueueAttributes where type ServiceConfiguration SetQueueAttributes = SqsConfiguration signQuery SetQueueAttributes {..} = sqsSignQuery SqsQuery { sqsQueueName = Just sqaQueueName, sqsQuery = [("Action", Just "SetQueueAttributes"), ("Attribute.Name", Just $ TE.encodeUtf8 $ printQueueAttribute sqaAttribute), ("Attribute.Value", Just $ TE.encodeUtf8 sqaValue)]} instance Transaction SetQueueAttributes SetQueueAttributesResponse instance AsMemoryResponse SetQueueAttributesResponse where type MemoryResponse SetQueueAttributesResponse = SetQueueAttributesResponse loadToMemory = returnaws-0.13.0/Aws/Sqs/Commands/Message.hs0000644000000000000000000007177412615132266015560 0ustar0000000000000000module Aws.Sqs.Commands.Message ( -- * User Message Attributes UserMessageAttributeCustomType , UserMessageAttributeValue(..) , UserMessageAttributeName , UserMessageAttribute -- * Send Message , SendMessage(..) , SendMessageResponse(..) -- * Delete Message , DeleteMessage(..) , DeleteMessageResponse(..) -- * Receive Message , Message(..) , ReceiveMessage(..) , ReceiveMessageResponse(..) -- * Change Message Visiblity , ChangeMessageVisibility(..) , ChangeMessageVisibilityResponse(..) ) where import Aws.Core import Aws.Sqs.Core import Control.Applicative import Control.Monad.Trans.Resource (throwM) import Data.Maybe import Data.Monoid import Text.XML.Cursor (($/), ($//), (&/), (&|)) import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Scientific import qualified Network.HTTP.Types as HTTP import Text.Read (readEither) import qualified Text.XML.Cursor as Cu -- -------------------------------------------------------------------------- -- -- User Message Attributes -- | You can append a custom type label to the supported data types (String, -- Number, and Binary) to create custom data types. This capability is similar -- to type traits in programming languages. For example, if you have an -- application that needs to know which type of number is being sent in the -- message, then you could create custom types similar to the following: -- Number.byte, Number.short, Number.int, and Number.float. Another example -- using the binary data type is to use Binary.gif and Binary.png to -- distinguish among different image file types in a message or batch of -- messages. The appended data is optional and opaque to Amazon SQS, which -- means that the appended data is not interpreted, validated, or used by -- Amazon SQS. The Custom Type extension has the same restrictions on allowed -- characters as the message body. -- type UserMessageAttributeCustomType = T.Text -- | Message Attribute Value -- -- The user-specified message attribute value. For string data types, the value -- attribute has the same restrictions on the content as the message body. For -- more information, see SendMessage. -- -- Name, type, and value must not be empty or null. In addition, the message -- body should not be empty or null. All parts of the message attribute, -- including name, type, and value, are included in the message size -- restriction, which is currently 256 KB (262,144 bytes). -- -- The supported message attribute data types are String, Number, and Binary. -- You can also provide custom information on the type. The data type has the -- same restrictions on the content as the message body. The data type is case -- sensitive, and it can be up to 256 bytes long. -- -- -- data UserMessageAttributeValue = UserMessageAttributeString (Maybe UserMessageAttributeCustomType) T.Text -- ^ Strings are Unicode with UTF-8 binary encoding. | UserMessageAttributeNumber (Maybe UserMessageAttributeCustomType) Scientific -- ^ Numbers are positive or negative integers or floating point numbers. -- Numbers have sufficient range and precision to encompass most of the -- possible values that integers, floats, and doubles typically support. A -- number can have up to 38 digits of precision, and it can be between -- 10^-128 to 10^+126. Leading and trailing zeroes are trimmed. | UserMessageAttributeBinary (Maybe UserMessageAttributeCustomType) B.ByteString -- ^ Binary type attributes can store any binary data, for example, -- compressed data, encrypted data, or images. -- UserMessageAttributesStringList (Maybe UserMessageAttributeCustomType) [T.Text] -- -- ^ Not implemented. Reserved for future use. -- UserMessageAttributeBinaryList (Maybe UserMessageAttributeCustomType) [B.ByteString] -- -- ^ Not implemented. Reserved for future use. deriving (Show, Read, Eq, Ord) -- | The message attribute name can contain the following characters: A-Z, a-z, -- 0-9, underscore(_), hyphen(-), and period (.). The name must not start or -- end with a period, and it should not have successive periods. The name is -- case sensitive and must be unique among all attribute names for the message. -- The name can be up to 256 characters long. The name cannot start with "AWS." -- or "Amazon." (or any variations in casing) because these prefixes are -- reserved for use by Amazon Web Services. -- type UserMessageAttributeName = T.Text -- | Message Attribute -- -- Name, type, and value must not be empty or null. In addition, the message -- body should not be empty or null. All parts of the message attribute, -- including name, type, and value, are included in the message size -- restriction, which is currently 256 KB (262,144 bytes). -- -- -- -- /NOTE/ -- -- The Amazon SQS API reference calls this /MessageAttribute/. The Haskell -- bindings use this term for what the Amazon documentation calls just -- /Attributes/. In order to limit backward compatibility issues we keep the -- terminology of the Haskell bindings and call this type -- /UserMessageAttributes/. -- type UserMessageAttribute = (UserMessageAttributeName, UserMessageAttributeValue) userMessageAttributesQuery :: [UserMessageAttribute] -> HTTP.Query userMessageAttributesQuery = concat . zipWith msgAttrQuery [1 :: Int ..] where msgAttrQuery i (name, value) = [ ( pre <> ".Name", Just $ TE.encodeUtf8 name ) , ( pre <> ".Value.DataType", Just typ ) , ( pre <> ".Value." <> valueKey, Just encodedValue ) ] where pre = "MessageAttribute." <> B.pack (show i) <> "." customType Nothing t = TE.encodeUtf8 t customType (Just c) t = TE.encodeUtf8 $ t <> "." <> c (typ, valueKey, encodedValue) = case value of UserMessageAttributeString c t -> (customType c "String", "StringValue", TE.encodeUtf8 t) UserMessageAttributeNumber c n -> (customType c "Number", "StringValue", B.pack $ show n) UserMessageAttributeBinary c b -> (customType c "Binary", "BinaryValue", b) -- -------------------------------------------------------------------------- -- -- Send Message -- | Delivers a message to the specified queue. With Amazon SQS, you now have -- the ability to send large payload messages that are up to 256KB (262,144 -- bytes) in size. To send large payloads, you must use an AWS SDK that -- supports SigV4 signing. To verify whether SigV4 is supported for an AWS SDK, -- check the SDK release notes. -- -- /IMPORTANT/ -- -- The following list shows the characters (in Unicode) allowed in your -- message, according to the W3C XML specification. For more information, go to -- If you send any characters not -- included in the list, your request will be rejected. -- -- > #x9 | #xA | #xD | [#x20 to #xD7FF] | [#xE000 to #xFFFD] | [#x10000 to #x10FFFF] -- -- -- data SendMessage = SendMessage { smMessage :: !T.Text -- ^ The message to send. String maximum 256 KB in size. , smQueueName :: !QueueName -- ^ The URL of the Amazon SQS queue to take action on. , smAttributes :: ![UserMessageAttribute] -- ^ Each message attribute consists of a Name, Type, and Value. , smDelaySeconds :: !(Maybe Int) -- ^ The number of seconds (0 to 900 - 15 minutes) to delay a specific -- message. Messages with a positive DelaySeconds value become available for -- processing after the delay time is finished. If you don't specify a value, -- the default value for the queue applies. } deriving (Show, Read, Eq, Ord) -- | At -- -- all fields of @SendMessageResult@ are denoted as optional. -- At -- -- all fields are specified as required. -- -- The actual service seems to treat at least 'smrMD5OfMessageAttributes' -- as optional. -- data SendMessageResponse = SendMessageResponse { smrMD5OfMessageBody :: !T.Text -- ^ An MD5 digest of the non-URL-encoded message body string. This can be -- used to verify that Amazon SQS received the message correctly. Amazon SQS -- first URL decodes the message before creating the MD5 digest. For -- information about MD5, go to . , smrMessageId :: !MessageId -- ^ An element containing the message ID of the message sent to the queue. , smrMD5OfMessageAttributes :: !(Maybe T.Text) -- ^ An MD5 digest of the non-URL-encoded message attribute string. This can -- be used to verify that Amazon SQS received the message correctly. Amazon -- SQS first URL decodes the message before creating the MD5 digest. For -- information about MD5, go to . } deriving (Show, Read, Eq, Ord) instance ResponseConsumer r SendMessageResponse where type ResponseMetadata SendMessageResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse el = SendMessageResponse <$> force "Missing MD5 Signature" (el $// Cu.laxElement "MD5OfMessageBody" &/ Cu.content) <*> (fmap MessageId . force "Missing Message Id") (el $// Cu.laxElement "MessageId" &/ Cu.content) <*> (pure . listToMaybe) (el $// Cu.laxElement "MD5OfMessageAttributes" &/ Cu.content) instance SignQuery SendMessage where type ServiceConfiguration SendMessage = SqsConfiguration signQuery SendMessage{..} = sqsSignQuery SqsQuery { sqsQueueName = Just smQueueName , sqsQuery = [ ("Action", Just "SendMessage") , ("MessageBody", Just $ TE.encodeUtf8 smMessage) ] <> userMessageAttributesQuery smAttributes <> maybeToList (("DelaySeconds",) . Just . B.pack . show <$> smDelaySeconds) } instance Transaction SendMessage SendMessageResponse instance AsMemoryResponse SendMessageResponse where type MemoryResponse SendMessageResponse = SendMessageResponse loadToMemory = return -- -------------------------------------------------------------------------- -- -- Delete Message -- | Deletes the specified message from the specified queue. You specify the -- message by using the message's receipt handle and not the message ID you -- received when you sent the message. Even if the message is locked by another -- reader due to the visibility timeout setting, it is still deleted from the -- queue. If you leave a message in the queue for longer than the queue's -- configured retention period, Amazon SQS automatically deletes it. -- -- /NOTE/ -- -- The receipt handle is associated with a specific instance of receiving the -- message. If you receive a message more than once, the receipt handle you get -- each time you receive the message is different. When you request -- DeleteMessage, if you don't provide the most recently received receipt -- handle for the message, the request will still succeed, but the message -- might not be deleted. -- -- /IMPORTANT/ -- -- It is possible you will receive a message even after you have deleted it. -- This might happen on rare occasions if one of the servers storing a copy of -- the message is unavailable when you request to delete the message. The copy -- remains on the server and might be returned to you again on a subsequent -- receive request. You should create your system to be idempotent so that -- receiving a particular message more than once is not a problem. -- -- -- data DeleteMessage = DeleteMessage { dmReceiptHandle :: !ReceiptHandle -- ^ The receipt handle associated with the message to delete. , dmQueueName :: !QueueName -- ^ The URL of the Amazon SQS queue to take action on. } deriving (Show, Read, Eq, Ord) data DeleteMessageResponse = DeleteMessageResponse {} deriving (Show, Read, Eq, Ord) instance ResponseConsumer r DeleteMessageResponse where type ResponseMetadata DeleteMessageResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = return DeleteMessageResponse {} instance SignQuery DeleteMessage where type ServiceConfiguration DeleteMessage = SqsConfiguration signQuery DeleteMessage{..} = sqsSignQuery SqsQuery { sqsQueueName = Just dmQueueName , sqsQuery = [ ("Action", Just "DeleteMessage") , ("ReceiptHandle", Just $ TE.encodeUtf8 $ printReceiptHandle dmReceiptHandle) ] } instance Transaction DeleteMessage DeleteMessageResponse instance AsMemoryResponse DeleteMessageResponse where type MemoryResponse DeleteMessageResponse = DeleteMessageResponse loadToMemory = return -- -------------------------------------------------------------------------- -- -- Receive Message -- | Retrieves one or more messages, with a maximum limit of 10 messages, from -- the specified queue. Long poll support is enabled by using the -- WaitTimeSeconds parameter. For more information, see -- -- in the Amazon SQS Developer Guide. -- -- Short poll is the default behavior where a weighted random set of machines -- is sampled on a ReceiveMessage call. This means only the messages on the -- sampled machines are returned. If the number of messages in the queue is -- small (less than 1000), it is likely you will get fewer messages than you -- requested per ReceiveMessage call. If the number of messages in the queue is -- extremely small, you might not receive any messages in a particular -- ReceiveMessage response; in which case you should repeat the request. -- -- For each message returned, the response includes the following: -- -- Message body -- -- * MD5 digest of the message body. For information about MD5, go to -- . -- -- * Message ID you received when you sent the message to the queue. -- -- * Receipt handle. -- -- * Message attributes. -- -- * MD5 digest of the message attributes. -- -- The receipt handle is the identifier you must provide when deleting the -- message. For more information, see Queue and Message Identifiers in the -- Amazon SQS Developer Guide. -- -- You can provide the VisibilityTimeout parameter in your request, which will -- be applied to the messages that Amazon SQS returns in the response. If you -- do not include the parameter, the overall visibility timeout for the queue -- is used for the returned messages. For more information, see Visibility -- Timeout in the Amazon SQS Developer Guide. -- -- /NOTE/ -- -- Going forward, new attributes might be added. If you are writing code that -- calls this action, we recommend that you structure your code so that it can -- handle new attributes gracefully. -- -- -- data ReceiveMessage = ReceiveMessage { rmVisibilityTimeout :: !(Maybe Int) -- ^ The duration (in seconds) that the received messages are hidden from -- subsequent retrieve requests after being retrieved by a ReceiveMessage -- request. , rmAttributes :: ![MessageAttribute] -- ^ A list of attributes that need to be returned along with each message. -- -- The following lists the names and descriptions of the attributes that can -- be returned: -- -- * All - returns all values. -- -- * ApproximateFirstReceiveTimestamp - returns the time when the message was -- first received (epoch time in milliseconds). -- -- * ApproximateReceiveCount - returns the number of times a message has been -- received but not deleted. -- -- * SenderId - returns the AWS account number (or the IP address, if -- anonymous access is allowed) of the sender. -- -- * SentTimestamp - returns the time when the message was sent (epoch time -- in milliseconds). , rmMaxNumberOfMessages :: !(Maybe Int) -- ^ The maximum number of messages to return. Amazon SQS never returns more -- messages than this value but may return fewer. Values can be from 1 to 10. -- Default is 1. -- -- All of the messages are not necessarily returned. , rmUserMessageAttributes :: ![UserMessageAttributeName] -- ^ The name of the message attribute, where N is the index. The message -- attribute name can contain the following characters: A-Z, a-z, 0-9, -- underscore (_), hyphen (-), and period (.). The name must not start or end -- with a period, and it should not have successive periods. The name is case -- sensitive and must be unique among all attribute names for the message. -- The name can be up to 256 characters long. The name cannot start with -- "AWS." or "Amazon." (or any variations in casing), because these prefixes -- are reserved for use by Amazon Web Services. -- -- When using ReceiveMessage, you can send a list of attribute names to -- receive, or you can return all of the attributes by specifying "All" or -- ".*" in your request. You can also use "foo.*" to return all message -- attributes starting with the "foo" prefix. , rmQueueName :: !QueueName -- ^The URL of the Amazon SQS queue to take action on. , rmWaitTimeSeconds :: !(Maybe Int) -- ^ The duration (in seconds) for which the call will wait for a message to -- arrive in the queue before returning. If a message is available, the call -- will return sooner than WaitTimeSeconds. } deriving (Show, Read, Eq, Ord) -- | An Amazon SQS message. -- -- In -- -- all elements are denoted as optional. -- In -- -- all elements except for the attributes are specified as required. -- At least for the field 'mMD5OfMessageAttributes' the the service -- is not always returning a value and therefor we make this field optional. -- data Message = Message { mMessageId :: !T.Text -- ^ A unique identifier for the message. Message IDs are considered unique -- across all AWS accounts for an extended period of time. , mReceiptHandle :: !ReceiptHandle -- ^ An identifier associated with the act of receiving the message. A new -- receipt handle is returned every time you receive a message. When deleting -- a message, you provide the last received receipt handle to delete the -- message. , mMD5OfBody :: !T.Text -- ^ An MD5 digest of the non-URL-encoded message body string. , mBody :: T.Text -- ^ The message's contents (not URL-encoded). , mAttributes :: ![(MessageAttribute,T.Text)] -- ^ SenderId, SentTimestamp, ApproximateReceiveCount, and/or -- ApproximateFirstReceiveTimestamp. SentTimestamp and -- ApproximateFirstReceiveTimestamp are each returned as an integer -- representing the epoch time in milliseconds. , mMD5OfMessageAttributes :: !(Maybe T.Text) -- ^ An MD5 digest of the non-URL-encoded message attribute string. This can -- be used to verify that Amazon SQS received the message correctly. Amazon -- SQS first URL decodes the message before creating the MD5 digest. For -- information about MD5, go to . , mUserMessageAttributes :: ![UserMessageAttribute] -- ^ Each message attribute consists of a Name, Type, and Value. } deriving(Show, Read, Eq, Ord) data ReceiveMessageResponse = ReceiveMessageResponse { rmrMessages :: ![Message] } deriving (Show, Read, Eq, Ord) readMessageAttribute :: Cu.Cursor -> Response SqsMetadata (MessageAttribute,T.Text) readMessageAttribute cursor = do name <- force "Missing Name" $ cursor $/ Cu.laxElement "Name" &/ Cu.content value <- force "Missing Value" $ cursor $/ Cu.laxElement "Value" &/ Cu.content parsedName <- parseMessageAttribute name return (parsedName, value) readUserMessageAttribute :: Cu.Cursor -> Response SqsMetadata UserMessageAttribute readUserMessageAttribute cursor = (,) <$> force "Missing Name" (cursor $/ Cu.laxElement "Name" &/ Cu.content) <*> readUserMessageAttributeValue cursor readUserMessageAttributeValue :: Cu.Cursor -> Response SqsMetadata UserMessageAttributeValue readUserMessageAttributeValue cursor = do typStr <- force "Missing DataType" $ cursor $/ Cu.laxElement "DataType" &/ Cu.content case parseType typStr of ("String", c) -> do val <- force "Missing StringValue" $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content return $ UserMessageAttributeString c val ("Number", c) -> do valStr <- force "Missing StringValue" $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content val <- tryXml . readEither $ T.unpack valStr return $ UserMessageAttributeNumber c val ("Binary", c) -> do val64 <- force "Missing StringValue" $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content val <- tryXml . B64.decode $ TE.encodeUtf8 val64 return $ UserMessageAttributeBinary c val (x, _) -> throwM . XmlException $ "unkown data type for MessageAttributeValue: " <> T.unpack x where parseType s = case T.break (== '.') s of (a, "") -> (a, Nothing) (a, x) -> (a, Just (T.tail x)) tryXml = either (throwM . XmlException) return readMessage :: Cu.Cursor -> Response SqsMetadata Message readMessage cursor = do mid <- force "Missing Message Id" $ cursor $// Cu.laxElement "MessageId" &/ Cu.content rh <- force "Missing Reciept Handle" $ cursor $// Cu.laxElement "ReceiptHandle" &/ Cu.content md5 <- force "Missing MD5 Signature" $ cursor $// Cu.laxElement "MD5OfBody" &/ Cu.content body <- force "Missing Body" $ cursor $// Cu.laxElement "Body" &/ Cu.content attributes <- sequence $ cursor $// Cu.laxElement "Attribute" &| readMessageAttribute userAttributes <- sequence $ cursor $// Cu.laxElement "MessageAttribute" &| readUserMessageAttribute let md5OfMessageAttributes = listToMaybe $ cursor $// Cu.laxElement "MD5OfMessageAttributes" &/ Cu.content return Message { mMessageId = mid , mReceiptHandle = ReceiptHandle rh , mMD5OfBody = md5 , mBody = body , mAttributes = attributes , mMD5OfMessageAttributes = md5OfMessageAttributes , mUserMessageAttributes = userAttributes } formatMAttributes :: [MessageAttribute] -> HTTP.Query formatMAttributes attrs = case attrs of [attr] -> [("AttributeName", encodeAttr attr)] _ -> zipWith f [1 :: Int ..] attrs where f x y = ("AttributeName." <> B.pack (show x), encodeAttr y) encodeAttr = Just . TE.encodeUtf8 . printMessageAttribute formatUserMessageAttributes :: [UserMessageAttributeName] -> HTTP.Query formatUserMessageAttributes attrs = case attrs of [attr] -> [("MessageAttributeName", encodeAttr attr)] _ -> zipWith f [1 :: Int ..] attrs where f x y = ("MessageAttributeName." <> B.pack (show x), encodeAttr y) encodeAttr = Just . TE.encodeUtf8 instance ResponseConsumer r ReceiveMessageResponse where type ResponseMetadata ReceiveMessageResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse el = do result <- force "Missing ReceiveMessageResult" $ el $// Cu.laxElement "ReceiveMessageResult" messages <- sequence $ result $// Cu.laxElement "Message" &| readMessage return ReceiveMessageResponse{ rmrMessages = messages } instance SignQuery ReceiveMessage where type ServiceConfiguration ReceiveMessage = SqsConfiguration signQuery ReceiveMessage{..} = sqsSignQuery SqsQuery { sqsQueueName = Just rmQueueName , sqsQuery = [ ("Action", Just "ReceiveMessage") ] <> catMaybes [ ("VisibilityTimeout",) <$> case rmVisibilityTimeout of Just x -> Just $ Just $ B.pack $ show x Nothing -> Nothing , ("MaxNumberOfMessages",) <$> case rmMaxNumberOfMessages of Just x -> Just $ Just $ B.pack $ show x Nothing -> Nothing , ("WaitTimeSeconds",) <$> case rmWaitTimeSeconds of Just x -> Just $ Just $ B.pack $ show x Nothing -> Nothing ] <> formatMAttributes rmAttributes <> formatUserMessageAttributes rmUserMessageAttributes } instance Transaction ReceiveMessage ReceiveMessageResponse instance AsMemoryResponse ReceiveMessageResponse where type MemoryResponse ReceiveMessageResponse = ReceiveMessageResponse loadToMemory = return -- -------------------------------------------------------------------------- -- -- Change Message Visibility -- | Changes the visibility timeout of a specified message in a queue to a new -- value. The maximum allowed timeout value you can set the value to is 12 -- hours. This means you can't extend the timeout of a message in an existing -- queue to more than a total visibility timeout of 12 hours. (For more -- information visibility timeout, see Visibility Timeout in the Amazon SQS -- Developer Guide.) -- -- For example, let's say you have a message and its default message visibility -- timeout is 30 minutes. You could call ChangeMessageVisiblity with a value of -- two hours and the effective timeout would be two hours and 30 minutes. When -- that time comes near you could again extend the time out by calling -- ChangeMessageVisiblity, but this time the maximum allowed timeout would be 9 -- hours and 30 minutes. -- -- /NOTE/ -- -- There is a 120,000 limit for the number of inflight messages per queue. -- Messages are inflight after they have been received from the queue by a -- consuming component, but have not yet been deleted from the queue. If you -- reach the 120,000 limit, you will receive an OverLimit error message from -- Amazon SQS. To help avoid reaching the limit, you should delete the messages -- from the queue after they have been processed. You can also increase the -- number of queues you use to process the messages. -- -- /IMPORTANT/ -- -- If you attempt to set the VisibilityTimeout to an amount more than the -- maximum time left, Amazon SQS returns an error. It will not automatically -- recalculate and increase the timeout to the maximum time remaining. -- -- /IMPORTANT/ -- -- Unlike with a queue, when you change the visibility timeout for a specific -- message, that timeout value is applied immediately but is not saved in -- memory for that message. If you don't delete a message after it is received, -- the visibility timeout for the message the next time it is received reverts -- to the original timeout value, not the value you set with the -- ChangeMessageVisibility action. -- -- -- data ChangeMessageVisibility = ChangeMessageVisibility { cmvReceiptHandle :: !ReceiptHandle -- ^ The receipt handle associated with the message whose visibility timeout -- should be changed. This parameter is returned by the ReceiveMessage -- action. , cmvVisibilityTimeout :: !Int -- ^ The new value (in seconds - from 0 to 43200 - maximum 12 hours) for the -- message's visibility timeout. , cmvQueueName :: !QueueName -- ^ The URL of the Amazon SQS queue to take action on. } deriving (Show, Read, Eq, Ord) data ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse {} deriving (Show, Read, Eq, Ord) instance ResponseConsumer r ChangeMessageVisibilityResponse where type ResponseMetadata ChangeMessageVisibilityResponse = SqsMetadata responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = return ChangeMessageVisibilityResponse {} -- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery ChangeMessageVisibility where type ServiceConfiguration ChangeMessageVisibility = SqsConfiguration signQuery ChangeMessageVisibility {..} = sqsSignQuery SqsQuery { sqsQueueName = Just cmvQueueName , sqsQuery = [ ("Action", Just "ChangeMessageVisibility") , ("ReceiptHandle", Just . TE.encodeUtf8 $ printReceiptHandle cmvReceiptHandle) , ("VisibilityTimeout", Just . B.pack $ show cmvVisibilityTimeout) ] } instance Transaction ChangeMessageVisibility ChangeMessageVisibilityResponse instance AsMemoryResponse ChangeMessageVisibilityResponse where type MemoryResponse ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse loadToMemory = return aws-0.13.0/Aws/Iam/0000755000000000000000000000000012615132266012017 5ustar0000000000000000aws-0.13.0/Aws/Iam/Commands.hs0000644000000000000000000000244312615132266014117 0ustar0000000000000000module Aws.Iam.Commands ( module Aws.Iam.Commands.CreateAccessKey , module Aws.Iam.Commands.CreateUser , module Aws.Iam.Commands.DeleteAccessKey , module Aws.Iam.Commands.DeleteUser , module Aws.Iam.Commands.DeleteUserPolicy , module Aws.Iam.Commands.GetUser , module Aws.Iam.Commands.GetUserPolicy , module Aws.Iam.Commands.ListAccessKeys , module Aws.Iam.Commands.ListMfaDevices , module Aws.Iam.Commands.ListUserPolicies , module Aws.Iam.Commands.ListUsers , module Aws.Iam.Commands.PutUserPolicy , module Aws.Iam.Commands.UpdateAccessKey , module Aws.Iam.Commands.UpdateUser ) where import Aws.Iam.Commands.CreateAccessKey import Aws.Iam.Commands.CreateUser import Aws.Iam.Commands.DeleteAccessKey import Aws.Iam.Commands.DeleteUser import Aws.Iam.Commands.DeleteUserPolicy import Aws.Iam.Commands.GetUser import Aws.Iam.Commands.GetUserPolicy import Aws.Iam.Commands.ListAccessKeys import Aws.Iam.Commands.ListMfaDevices import Aws.Iam.Commands.ListUserPolicies import Aws.Iam.Commands.ListUsers import Aws.Iam.Commands.PutUserPolicy import Aws.Iam.Commands.UpdateAccessKey import Aws.Iam.Commands.UpdateUser aws-0.13.0/Aws/Iam/Core.hs0000644000000000000000000002055612615132266013253 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} module Aws.Iam.Core ( iamSignQuery , iamResponseConsumer , IamMetadata(..) , IamConfiguration(..) , IamError(..) , parseDateTime , AccessKeyStatus(..) , User(..) , parseUser , MfaDevice(..) , parseMfaDevice ) where import Aws.Core import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import Control.Exception (Exception) import Control.Monad import Control.Monad.Trans.Resource (MonadThrow, throwM) import Data.ByteString (ByteString) import Data.IORef import Data.List (intersperse, sort) import Data.Maybe import Data.Monoid import Data.Text (Text) import qualified Data.Text as Text import Data.Time import Data.Typeable import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP #if MIN_VERSION_time(1,5,0) import Data.Time.Format #else import System.Locale #endif import Text.XML.Cursor (($//)) import qualified Text.XML.Cursor as Cu data IamError = IamError { iamStatusCode :: HTTP.Status , iamErrorCode :: Text , iamErrorMessage :: Text } deriving (Show, Typeable) instance Exception IamError data IamMetadata = IamMetadata { requestId :: Maybe Text } deriving (Show, Typeable) instance Loggable IamMetadata where toLogText (IamMetadata r) = "IAM: request ID=" <> fromMaybe "" r instance Monoid IamMetadata where mempty = IamMetadata Nothing IamMetadata r1 `mappend` IamMetadata r2 = IamMetadata (r1 `mplus` r2) data IamConfiguration qt = IamConfiguration { iamEndpoint :: ByteString , iamPort :: Int , iamProtocol :: Protocol , iamHttpMethod :: Method } deriving (Show) instance DefaultServiceConfiguration (IamConfiguration NormalQuery) where defServiceConfig = iam PostQuery HTTPS iamEndpointDefault debugServiceConfig = iam PostQuery HTTP iamEndpointDefault instance DefaultServiceConfiguration (IamConfiguration UriOnlyQuery) where defServiceConfig = iam Get HTTPS iamEndpointDefault debugServiceConfig = iam Get HTTP iamEndpointDefault -- | The default IAM endpoint. iamEndpointDefault :: ByteString iamEndpointDefault = "iam.amazonaws.com" -- | Constructs an IamConfiguration with the specified parameters. iam :: Method -> Protocol -> ByteString -> IamConfiguration qt iam method protocol endpoint = IamConfiguration { iamEndpoint = endpoint , iamProtocol = protocol , iamPort = defaultPort protocol , iamHttpMethod = method } -- | Constructs a 'SignedQuery' with the specified request parameters. iamSignQuery :: [(ByteString, ByteString)] -- ^ Pairs of parameter names and values that will be passed as part of -- the request data. -> IamConfiguration qt -> SignatureData -> SignedQuery iamSignQuery q IamConfiguration{..} SignatureData{..} = SignedQuery { sqMethod = iamHttpMethod , sqProtocol = iamProtocol , sqHost = iamEndpoint , sqPort = iamPort , sqPath = "/" , sqQuery = signedQuery , sqDate = Just signatureTime , sqAuthorization = Nothing , sqContentType = Nothing , sqContentMd5 = Nothing , sqAmzHeaders = [] , sqOtherHeaders = [] , sqBody = Nothing , sqStringToSign = stringToSign } where sig = signature signatureCredentials HmacSHA256 stringToSign signedQuery = ("Signature", Just sig):expandedQuery accessKey = accessKeyID signatureCredentials timestampHeader = case signatureTimeInfo of AbsoluteTimestamp time -> ("Timestamp", Just $ fmtAmzTime time) AbsoluteExpires time -> ("Expires" , Just $ fmtAmzTime time) newline = Blaze8.fromChar '\n' stringToSign = Blaze.toByteString . mconcat . intersperse newline $ map Blaze.copyByteString [httpMethod iamHttpMethod, iamEndpoint, "/"] ++ [HTTP.renderQueryBuilder False expandedQuery] expandedQuery = HTTP.toQuery . sort $ (map (\(a,b) -> (a, Just b)) q ++) [ ("AWSAccessKeyId" , Just accessKey) , ("SignatureMethod" , Just $ amzHash HmacSHA256) , ("SignatureVersion", Just "2") , ("Version" , Just "2010-05-08") , timestampHeader] ++ maybe [] (\tok -> [ ("SecurityToken", Just tok)]) (iamToken signatureCredentials) -- | Reads the metadata from an IAM response and delegates parsing the rest of -- the data from the response to the given function. iamResponseConsumer :: (Cu.Cursor -> Response IamMetadata a) -> IORef IamMetadata -> HTTPResponseConsumer a iamResponseConsumer inner md resp = xmlCursorConsumer parse md resp where parse cursor = do let rid = listToMaybe $ cursor $// elContent "RequestID" tellMetadata $ IamMetadata rid case cursor $// Cu.laxElement "Error" of [] -> inner cursor (err:_) -> fromError err fromError cursor = do errCode <- force "Missing Error Code" $ cursor $// elContent "Code" errMsg <- force "Missing Error Message" $ cursor $// elContent "Message" throwM $ IamError (HTTP.responseStatus resp) errCode errMsg -- | Parses IAM @DateTime@ data type. parseDateTime :: MonadThrow m => String -> m UTCTime parseDateTime x = case parseTime defaultTimeLocale iso8601UtcDate x of Nothing -> throwM $ XmlException $ "Invalid DateTime: " ++ x Just dt -> return dt -- | The IAM @User@ data type. -- -- data User = User { userArn :: Text -- ^ ARN used to refer to this user. , userCreateDate :: UTCTime -- ^ Date and time at which the user was created. , userPath :: Text -- ^ Path under which the user was created. , userUserId :: Text -- ^ Unique identifier used to refer to this user. , userUserName :: Text -- ^ Name of the user. } deriving (Eq, Ord, Show, Typeable) -- | Parses the IAM @User@ data type. parseUser :: MonadThrow m => Cu.Cursor -> m User parseUser cursor = do userArn <- attr "Arn" userCreateDate <- attr "CreateDate" >>= parseDateTime . Text.unpack userPath <- attr "Path" userUserId <- attr "UserId" userUserName <- attr "UserName" return User{..} where attr name = force ("Missing " ++ Text.unpack name) $ cursor $// elContent name data AccessKeyStatus = AccessKeyActive | AccessKeyInactive deriving (Eq, Ord, Show, Typeable) -- | The IAM @MFADevice@ data type. -- -- data MfaDevice = MfaDevice { mfaEnableDate :: UTCTime -- ^ The date when the MFA device was enabled for -- the user. , mfaSerialNumber :: Text -- ^ The serial number that uniquely identifies the -- MFA device. For virtual MFA devices, the serial -- number is the device ARN. , mfaUserName :: Text -- ^ The user with whom the MFA device is -- associated. Minimum length of 1. Maximum length -- of 64. } deriving (Eq, Ord, Show, Typeable) -- | Parses the IAM @MFADevice@ data type. parseMfaDevice :: MonadThrow m => Cu.Cursor -> m MfaDevice parseMfaDevice cursor = do mfaEnableDate <- attr "EnableDate" >>= parseDateTime . Text.unpack mfaSerialNumber <- attr "SerialNumber" mfaUserName <- attr "UserName" return MfaDevice{..} where attr name = force ("Missing " ++ Text.unpack name) $ cursor $// elContent name aws-0.13.0/Aws/Iam/Internal.hs0000644000000000000000000000463212615132266014134 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TupleSections #-} module Aws.Iam.Internal ( iamAction , iamAction' , markedIter , markedIterResponse -- * Re-exports , (<>) ) where import Aws.Core import Aws.Iam.Core import Control.Applicative import Control.Arrow (second) import Control.Monad import Control.Monad.Trans.Resource (MonadThrow) import Data.ByteString (ByteString) import Data.Maybe import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Text.XML.Cursor (($//)) import qualified Text.XML.Cursor as Cu -- | Similar to 'iamSignQuery'. Accepts parameters in @Text@ form and UTF-8 -- encodes them. Accepts the @Action@ parameter separately since it's always -- required. iamAction :: ByteString -> [(ByteString, Text)] -> IamConfiguration qt -> SignatureData -> SignedQuery iamAction action = iamSignQuery . (:) ("Action", action) . map (second Text.encodeUtf8) -- | Similar to 'iamAction'. Accepts parameter list with @Maybe@ parameters. -- Ignores @Nothing@s. iamAction' :: ByteString -> [Maybe (ByteString, Text)] -> IamConfiguration qt -> SignatureData -> SignedQuery iamAction' action = iamAction action . catMaybes -- | Returns the parameters @Marker@ and @MaxItems@ that are present in all -- IAM data pagination requests. markedIter :: Maybe Text -> Maybe Integer -> [Maybe (ByteString, Text)] markedIter marker maxItems = [ ("Marker" ,) <$> marker , ("MaxItems",) . encodeInteger <$> maxItems ] where encodeInteger = Text.pack . show -- | Reads and returns the @IsTruncated@ and @Marker@ attributes present in -- all IAM data pagination responses. markedIterResponse :: MonadThrow m => Cu.Cursor -> m (Bool, Maybe Text) markedIterResponse cursor = do isTruncated <- (Text.toCaseFold "true" ==) `liftM` attr "IsTruncated" marker <- if isTruncated then Just `liftM` attr "Marker" else return Nothing return (isTruncated, marker) where attr name = force ("Missing " ++ Text.unpack name) $ cursor $// elContent name aws-0.13.0/Aws/Iam/Commands/0000755000000000000000000000000012615132266013560 5ustar0000000000000000aws-0.13.0/Aws/Iam/Commands/UpdateAccessKey.hs0000644000000000000000000000401712615132266017133 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.UpdateAccessKey ( UpdateAccessKey(..) , UpdateAccessKeyResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import Data.Typeable -- | Changes the status of the specified access key. -- -- data UpdateAccessKey = UpdateAccessKey { uakAccessKeyId :: Text -- ^ ID of the access key to update. , uakStatus :: AccessKeyStatus -- ^ New status of the access key. , uakUserName :: Maybe Text -- ^ Name of the user to whom the access key belongs. If omitted, the -- user will be determined based on the access key used to sign the -- request. } deriving (Eq, Ord, Show, Typeable) instance SignQuery UpdateAccessKey where type ServiceConfiguration UpdateAccessKey = IamConfiguration signQuery UpdateAccessKey{..} = iamAction' "UpdateAccessKey" [ Just ("AccessKeyId", uakAccessKeyId) , Just ("Status", showStatus uakStatus) , ("UserName",) <$> uakUserName ] where showStatus AccessKeyActive = "Active" showStatus _ = "Inactive" data UpdateAccessKeyResponse = UpdateAccessKeyResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer UpdateAccessKey UpdateAccessKeyResponse where type ResponseMetadata UpdateAccessKeyResponse = IamMetadata responseConsumer _ = iamResponseConsumer (const $ return UpdateAccessKeyResponse) instance Transaction UpdateAccessKey UpdateAccessKeyResponse instance AsMemoryResponse UpdateAccessKeyResponse where type MemoryResponse UpdateAccessKeyResponse = UpdateAccessKeyResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/ListUsers.hs0000644000000000000000000000527712615132266016064 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.ListUsers ( ListUsers(..) , ListUsersResponse(..) , User(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import Data.Typeable import Text.XML.Cursor (laxElement, ($//), (&|)) -- | Lists users that have the specified path prefix. -- -- data ListUsers = ListUsers { luPathPrefix :: Maybe Text -- ^ Users defined under this path will be listed. If omitted, defaults -- to @/@, which lists all users. , luMarker :: Maybe Text -- ^ Used for paginating requests. Marks the position of the last -- request. , luMaxItems :: Maybe Integer -- ^ Used for paginating requests. Specifies the maximum number of items -- to return in the response. Defaults to 100. } deriving (Eq, Ord, Show, Typeable) instance SignQuery ListUsers where type ServiceConfiguration ListUsers = IamConfiguration signQuery ListUsers{..} = iamAction' "ListUsers" $ [ ("PathPrefix",) <$> luPathPrefix ] <> markedIter luMarker luMaxItems data ListUsersResponse = ListUsersResponse { lurUsers :: [User] -- ^ List of 'User's. , lurIsTruncated :: Bool -- ^ @True@ if the request was truncated because of too many items. , lurMarker :: Maybe Text -- ^ Marks the position at which the request was truncated. This value -- must be passed with the next request to continue listing from the -- last position. } deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer ListUsers ListUsersResponse where type ResponseMetadata ListUsersResponse = IamMetadata responseConsumer _ = iamResponseConsumer $ \cursor -> do (lurIsTruncated, lurMarker) <- markedIterResponse cursor lurUsers <- sequence $ cursor $// laxElement "member" &| parseUser return ListUsersResponse{..} instance Transaction ListUsers ListUsersResponse instance IteratedTransaction ListUsers ListUsersResponse where nextIteratedRequest request response = case lurMarker response of Nothing -> Nothing Just marker -> Just $ request { luMarker = Just marker } instance AsMemoryResponse ListUsersResponse where type MemoryResponse ListUsersResponse = ListUsersResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/CreateUser.hs0000644000000000000000000000311212615132266016153 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.CreateUser ( CreateUser(..) , CreateUserResponse(..) , User(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import Data.Typeable -- | Creates a new user. -- -- data CreateUser = CreateUser { cuUserName :: Text -- ^ Name of the new user , cuPath :: Maybe Text -- ^ Path under which the user will be created. Defaults to @/@ if -- omitted. } deriving (Eq, Ord, Show, Typeable) instance SignQuery CreateUser where type ServiceConfiguration CreateUser = IamConfiguration signQuery CreateUser{..} = iamAction' "CreateUser" [ Just ("UserName", cuUserName) , ("Path",) <$> cuPath ] data CreateUserResponse = CreateUserResponse User deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer CreateUser CreateUserResponse where type ResponseMetadata CreateUserResponse = IamMetadata responseConsumer _ = iamResponseConsumer $ fmap CreateUserResponse . parseUser instance Transaction CreateUser CreateUserResponse instance AsMemoryResponse CreateUserResponse where type MemoryResponse CreateUserResponse = CreateUserResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/DeleteUser.hs0000644000000000000000000000225712615132266016163 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.DeleteUser ( DeleteUser(..) , DeleteUserResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Data.Text (Text) import Data.Typeable -- | Deletes the specified user. -- -- data DeleteUser = DeleteUser Text deriving (Eq, Ord, Show, Typeable) instance SignQuery DeleteUser where type ServiceConfiguration DeleteUser = IamConfiguration signQuery (DeleteUser userName) = iamAction "DeleteUser" [("UserName", userName)] data DeleteUserResponse = DeleteUserResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer DeleteUser DeleteUserResponse where type ResponseMetadata DeleteUserResponse = IamMetadata responseConsumer _ = iamResponseConsumer (const $ return DeleteUserResponse) instance Transaction DeleteUser DeleteUserResponse instance AsMemoryResponse DeleteUserResponse where type MemoryResponse DeleteUserResponse = DeleteUserResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/DeleteUserPolicy.hs0000644000000000000000000000315712615132266017343 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.DeleteUserPolicy ( DeleteUserPolicy(..) , DeleteUserPolicyResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Data.Text (Text) import Data.Typeable -- | Deletes the specified policy associated with the specified user. -- -- data DeleteUserPolicy = DeleteUserPolicy { dupPolicyName :: Text -- ^ Name of the policy to be deleted. , dupUserName :: Text -- ^ Name of the user with whom the policy is associated. } deriving (Eq, Ord, Show, Typeable) instance SignQuery DeleteUserPolicy where type ServiceConfiguration DeleteUserPolicy = IamConfiguration signQuery DeleteUserPolicy{..} = iamAction "DeleteUserPolicy" [ ("PolicyName", dupPolicyName) , ("UserName", dupUserName) ] data DeleteUserPolicyResponse = DeleteUserPolicyResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer DeleteUserPolicy DeleteUserPolicyResponse where type ResponseMetadata DeleteUserPolicyResponse = IamMetadata responseConsumer _ = iamResponseConsumer (const $ return DeleteUserPolicyResponse) instance Transaction DeleteUserPolicy DeleteUserPolicyResponse instance AsMemoryResponse DeleteUserPolicyResponse where type MemoryResponse DeleteUserPolicyResponse = DeleteUserPolicyResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/GetUser.hs0000644000000000000000000000256112615132266015476 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.GetUser ( GetUser(..) , GetUserResponse(..) , User(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import Data.Typeable -- | Retreives information about the given user. -- -- If a user name is not given, IAM determines the user name based on the -- access key signing the request. -- -- data GetUser = GetUser (Maybe Text) deriving (Eq, Ord, Show, Typeable) instance SignQuery GetUser where type ServiceConfiguration GetUser = IamConfiguration signQuery (GetUser user) = iamAction' "GetUser" [("UserName",) <$> user] data GetUserResponse = GetUserResponse User deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer GetUser GetUserResponse where type ResponseMetadata GetUserResponse = IamMetadata responseConsumer _ = iamResponseConsumer $ fmap GetUserResponse . parseUser instance Transaction GetUser GetUserResponse instance AsMemoryResponse GetUserResponse where type MemoryResponse GetUserResponse = GetUserResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/ListUserPolicies.hs0000644000000000000000000000536212615132266017364 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.ListUserPolicies ( ListUserPolicies(..) , ListUserPoliciesResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Data.Text (Text) import Data.Typeable import Text.XML.Cursor (content, laxElement, ($//), (&/)) -- | Lists the user policies associated with the specified user. -- -- data ListUserPolicies = ListUserPolicies { lupUserName :: Text -- ^ Policies associated with this user will be listed. , lupMarker :: Maybe Text -- ^ Used for paginating requests. Marks the position of the last -- request. , lupMaxItems :: Maybe Integer -- ^ Used for paginating requests. Specifies the maximum number of items -- to return in the response. Defaults to 100. } deriving (Eq, Ord, Show, Typeable) instance SignQuery ListUserPolicies where type ServiceConfiguration ListUserPolicies = IamConfiguration signQuery ListUserPolicies{..} = iamAction' "ListUserPolicies" $ [ Just ("UserName", lupUserName) ] <> markedIter lupMarker lupMaxItems data ListUserPoliciesResponse = ListUserPoliciesResponse { luprPolicyNames :: [Text] -- ^ List of policy names. , luprIsTruncated :: Bool -- ^ @True@ if the request was truncated because of too many items. , luprMarker :: Maybe Text -- ^ Marks the position at which the request was truncated. This value -- must be passed with the next request to continue listing from the -- last position. } deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer ListUserPolicies ListUserPoliciesResponse where type ResponseMetadata ListUserPoliciesResponse = IamMetadata responseConsumer _ = iamResponseConsumer $ \cursor -> do (luprIsTruncated, luprMarker) <- markedIterResponse cursor let luprPolicyNames = cursor $// laxElement "member" &/ content return ListUserPoliciesResponse{..} instance Transaction ListUserPolicies ListUserPoliciesResponse instance IteratedTransaction ListUserPolicies ListUserPoliciesResponse where nextIteratedRequest request response = case luprMarker response of Nothing -> Nothing Just marker -> Just $ request { lupMarker = Just marker } instance AsMemoryResponse ListUserPoliciesResponse where type MemoryResponse ListUserPoliciesResponse = ListUserPoliciesResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/ListMfaDevices.hs0000644000000000000000000000720512615132266016762 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} module Aws.Iam.Commands.ListMfaDevices ( ListMfaDevices(..) , ListMfaDevicesResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import Data.Typeable import Text.XML.Cursor (laxElement, ($//), (&|)) -- | Lists the MFA devices. If the request includes the user name, -- then this action lists all the MFA devices associated with the -- specified user name. If you do not specify a user name, IAM -- determines the user name implicitly based on the AWS access key ID -- signing the request. -- -- data ListMfaDevices = ListMfaDevices { lmfaUserName :: Maybe Text -- ^ The name of the user whose MFA devices -- you want to list. If you do not specify a -- user name, IAM determines the user name -- implicitly based on the AWS access key ID -- signing the request , lmfaMarker :: Maybe Text -- ^ Used for paginating requests. Marks the -- position of the last request. , lmfaMaxItems :: Maybe Integer -- ^ Used for paginating requests. Specifies -- the maximum number of items to return in -- the response. Defaults to 100. } deriving (Eq, Ord, Show, Typeable) instance SignQuery ListMfaDevices where type ServiceConfiguration ListMfaDevices = IamConfiguration signQuery ListMfaDevices{..} = iamAction' "ListMFADevices" ([ ("UserName",) <$> lmfaUserName ] <> markedIter lmfaMarker lmfaMaxItems) data ListMfaDevicesResponse = ListMfaDevicesResponse { lmfarMfaDevices :: [MfaDevice] -- ^ List of 'MFA Device's. , lmfarIsTruncated :: Bool -- ^ @True@ if the request was -- truncated because of too many -- items. , lmfarMarker :: Maybe Text -- ^ Marks the position at which the -- request was truncated. This value -- must be passed with the next -- request to continue listing from -- the last position. } deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer ListMfaDevices ListMfaDevicesResponse where type ResponseMetadata ListMfaDevicesResponse = IamMetadata responseConsumer _req = iamResponseConsumer $ \ cursor -> do (lmfarIsTruncated, lmfarMarker) <- markedIterResponse cursor lmfarMfaDevices <- sequence $ cursor $// laxElement "member" &| parseMfaDevice return ListMfaDevicesResponse{..} instance Transaction ListMfaDevices ListMfaDevicesResponse instance IteratedTransaction ListMfaDevices ListMfaDevicesResponse where nextIteratedRequest request response = case lmfarMarker response of Nothing -> Nothing Just marker -> Just $ request { lmfaMarker = Just marker } instance AsMemoryResponse ListMfaDevicesResponse where type MemoryResponse ListMfaDevicesResponse = ListMfaDevicesResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/UpdateUser.hs0000644000000000000000000000325312615132266016200 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.UpdateUser ( UpdateUser(..) , UpdateUserResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import Data.Typeable -- | Updates the name and/or path of the specified user. -- -- data UpdateUser = UpdateUser { uuUserName :: Text -- ^ Name of the user to be updated. , uuNewUserName :: Maybe Text -- ^ New name for the user. , uuNewPath :: Maybe Text -- ^ New path to which the user will be moved. } deriving (Eq, Ord, Show, Typeable) instance SignQuery UpdateUser where type ServiceConfiguration UpdateUser = IamConfiguration signQuery UpdateUser{..} = iamAction' "UpdateUser" [ Just ("UserName", uuUserName) , ("NewUserName",) <$> uuNewUserName , ("NewPath",) <$> uuNewPath ] data UpdateUserResponse = UpdateUserResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer UpdateUser UpdateUserResponse where type ResponseMetadata UpdateUserResponse = IamMetadata responseConsumer _ = iamResponseConsumer (const $ return UpdateUserResponse) instance Transaction UpdateUser UpdateUserResponse instance AsMemoryResponse UpdateUserResponse where type MemoryResponse UpdateUserResponse = UpdateUserResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/CreateAccessKey.hs0000644000000000000000000000626612615132266017124 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.CreateAccessKey ( CreateAccessKey(..) , CreateAccessKeyResponse(..) , AccessKey(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import qualified Data.Text as Text import Data.Time import Data.Typeable import Text.XML.Cursor (($//)) -- | Creates a new AWS secret access key and corresponding AWS access key ID -- for the given user name. -- -- If a user name is not provided, IAM will determine the user name based on -- the access key signing the request. -- -- data CreateAccessKey = CreateAccessKey (Maybe Text) deriving (Eq, Ord, Show, Typeable) instance SignQuery CreateAccessKey where type ServiceConfiguration CreateAccessKey = IamConfiguration signQuery (CreateAccessKey user) = iamAction' "CreateAccessKey" [("UserName",) <$> user] -- | Represents the IAM @AccessKey@ data type. -- -- data AccessKey = AccessKey { akAccessKeyId :: Text -- ^ The Access Key ID. , akCreateDate :: Maybe UTCTime -- ^ Date and time at which the access key was created. , akSecretAccessKey :: Text -- ^ Secret key used to sign requests. The secret key is accessible only -- during key creation. , akStatus :: AccessKeyStatus -- ^ Whether the access key is active or not. , akUserName :: Text -- ^ The user name for which this key is defined. } deriving (Eq, Ord, Show, Typeable) data CreateAccessKeyResponse = CreateAccessKeyResponse AccessKey deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer CreateAccessKey CreateAccessKeyResponse where type ResponseMetadata CreateAccessKeyResponse = IamMetadata responseConsumer _ = iamResponseConsumer $ \cursor -> do let attr name = force ("Missing " ++ Text.unpack name) $ cursor $// elContent name akAccessKeyId <- attr "AccessKeyId" akSecretAccessKey <- attr "SecretAccessKey" akStatus <- readAccessKeyStatus <$> attr "Status" akUserName <- attr "UserName" akCreateDate <- readDate cursor return $ CreateAccessKeyResponse AccessKey{..} where readDate c = case c $// elCont "CreateDate" of (x:_) -> Just <$> parseDateTime x _ -> return Nothing readAccessKeyStatus s | Text.toCaseFold s == "Active" = AccessKeyActive | otherwise = AccessKeyInactive instance Transaction CreateAccessKey CreateAccessKeyResponse instance AsMemoryResponse CreateAccessKeyResponse where type MemoryResponse CreateAccessKeyResponse = CreateAccessKeyResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/GetUserPolicy.hs0000644000000000000000000000472312615132266016660 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.GetUserPolicy ( GetUserPolicy(..) , GetUserPolicyResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Typeable import qualified Network.HTTP.Types as HTTP import Text.XML.Cursor (($//)) -- | Retreives the specified policy document for the specified user. -- -- data GetUserPolicy = GetUserPolicy { gupPolicyName :: Text -- ^ Name of the policy. , gupUserName :: Text -- ^ Name of the user with whom the policy is associated. } deriving (Eq, Ord, Show, Typeable) instance SignQuery GetUserPolicy where type ServiceConfiguration GetUserPolicy = IamConfiguration signQuery GetUserPolicy{..} = iamAction "GetUserPolicy" [ ("PolicyName", gupPolicyName) , ("UserName", gupUserName) ] data GetUserPolicyResponse = GetUserPolicyResponse { guprPolicyDocument :: Text -- ^ The policy document. , guprPolicyName :: Text -- ^ Name of the policy. , guprUserName :: Text -- ^ Name of the user with whom the policy is associated. } deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer GetUserPolicy GetUserPolicyResponse where type ResponseMetadata GetUserPolicyResponse = IamMetadata responseConsumer _ = iamResponseConsumer $ \cursor -> do let attr name = force ("Missing " ++ Text.unpack name) $ cursor $// elContent name guprPolicyDocument <- decodePolicy <$> attr "PolicyDocument" guprPolicyName <- attr "PolicyName" guprUserName <- attr "UserName" return GetUserPolicyResponse{..} where decodePolicy = Text.decodeUtf8 . HTTP.urlDecode False . Text.encodeUtf8 instance Transaction GetUserPolicy GetUserPolicyResponse instance AsMemoryResponse GetUserPolicyResponse where type MemoryResponse GetUserPolicyResponse = GetUserPolicyResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/ListAccessKeys.hs0000644000000000000000000001007212615132266017005 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.ListAccessKeys ( ListAccessKeys(..) , ListAccessKeysResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import Data.Time import Data.Typeable import Text.XML.Cursor (laxElement, ($/), ($//), (&|)) -- | Returns the access keys associated with the specified user. -- -- data ListAccessKeys = ListAccessKeys { lakUserName :: Maybe Text -- ^ Name of the user. If the user name is not specified, IAM will -- determine the user based on the key sigining the request. , lakMarker :: Maybe Text -- ^ Used for paginating requests. Marks the position of the last -- request. , lakMaxItems :: Maybe Integer -- ^ Used for paginating requests. Specifies the maximum number of items -- to return in the response. Defaults to 100. } deriving (Eq, Ord, Show, Typeable) instance SignQuery ListAccessKeys where type ServiceConfiguration ListAccessKeys = IamConfiguration signQuery ListAccessKeys{..} = iamAction' "ListAccessKeys" $ [ ("UserName",) <$> lakUserName ] <> markedIter lakMarker lakMaxItems -- | Represents the IAM @AccessKeyMetadata@ data type. -- -- data AccessKeyMetadata = AccessKeyMetadata { akmAccessKeyId :: Maybe Text -- ^ ID of the access key. , akmCreateDate :: Maybe UTCTime -- ^ Date and time at which the access key was created. , akmStatus :: Maybe Text -- ^ Whether the access key is active. , akmUserName :: Maybe Text -- ^ Name of the user with whom the access key is associated. } deriving (Eq, Ord, Show, Typeable) data ListAccessKeysResponse = ListAccessKeysResponse { lakrAccessKeyMetadata :: [AccessKeyMetadata] -- ^ List of 'AccessKeyMetadata' objects , lakrIsTruncated :: Bool -- ^ @True@ if the request was truncated because of too many items. , lakrMarker :: Maybe Text -- ^ Marks the position at which the request was truncated. This value -- must be passed with the next request to continue listing from the -- last position. } deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer ListAccessKeys ListAccessKeysResponse where type ResponseMetadata ListAccessKeysResponse = IamMetadata responseConsumer _ = iamResponseConsumer $ \cursor -> do (lakrIsTruncated, lakrMarker) <- markedIterResponse cursor lakrAccessKeyMetadata <- sequence $ cursor $// laxElement "member" &| buildAKM return ListAccessKeysResponse{..} where buildAKM m = do let mattr name = mhead $ m $/ elContent name let akmAccessKeyId = mattr "AccessKeyId" akmStatus = mattr "Status" akmUserName = mattr "UserName" akmCreateDate <- case m $/ elCont "CreateDate" of (x:_) -> Just <$> parseDateTime x _ -> return Nothing return AccessKeyMetadata{..} mhead (x:_) = Just x mhead _ = Nothing instance Transaction ListAccessKeys ListAccessKeysResponse instance IteratedTransaction ListAccessKeys ListAccessKeysResponse where nextIteratedRequest request response = case lakrMarker response of Nothing -> Nothing Just marker -> Just $ request { lakMarker = Just marker } instance AsMemoryResponse ListAccessKeysResponse where type MemoryResponse ListAccessKeysResponse = ListAccessKeysResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/DeleteAccessKey.hs0000644000000000000000000000326512615132266017117 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.DeleteAccessKey ( DeleteAccessKey(..) , DeleteAccessKeyResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Control.Applicative import Data.Text (Text) import Data.Typeable -- | Deletes the access key associated with the specified user. -- -- data DeleteAccessKey = DeleteAccessKey { dakAccessKeyId :: Text -- ^ ID of the access key to be deleted. , dakUserName :: Maybe Text -- ^ User name with which the access key is associated. } deriving (Eq, Ord, Show, Typeable) instance SignQuery DeleteAccessKey where type ServiceConfiguration DeleteAccessKey = IamConfiguration signQuery DeleteAccessKey{..} = iamAction' "DeleteAccessKey" [ Just ("AccessKeyId", dakAccessKeyId) , ("UserName",) <$> dakUserName ] data DeleteAccessKeyResponse = DeleteAccessKeyResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer DeleteAccessKey DeleteAccessKeyResponse where type ResponseMetadata DeleteAccessKeyResponse = IamMetadata responseConsumer _ = iamResponseConsumer (const $ return DeleteAccessKeyResponse) instance Transaction DeleteAccessKey DeleteAccessKeyResponse instance AsMemoryResponse DeleteAccessKeyResponse where type MemoryResponse DeleteAccessKeyResponse = DeleteAccessKeyResponse loadToMemory = return aws-0.13.0/Aws/Iam/Commands/PutUserPolicy.hs0000644000000000000000000000330712615132266016706 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Aws.Iam.Commands.PutUserPolicy ( PutUserPolicy(..) , PutUserPolicyResponse(..) ) where import Aws.Core import Aws.Iam.Core import Aws.Iam.Internal import Data.Text (Text) import Data.Typeable -- | Adds a policy document with the specified name, associated with the -- specified user. -- -- data PutUserPolicy = PutUserPolicy { pupPolicyDocument :: Text -- ^ The policy document. , pupPolicyName :: Text -- ^ Name of the policy. , pupUserName :: Text -- ^ Name of the user with whom this policy is associated. } deriving (Eq, Ord, Show, Typeable) instance SignQuery PutUserPolicy where type ServiceConfiguration PutUserPolicy = IamConfiguration signQuery PutUserPolicy{..} = iamAction "PutUserPolicy" [ ("PolicyDocument", pupPolicyDocument) , ("PolicyName" , pupPolicyName) , ("UserName" , pupUserName) ] data PutUserPolicyResponse = PutUserPolicyResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer PutUserPolicy PutUserPolicyResponse where type ResponseMetadata PutUserPolicyResponse = IamMetadata responseConsumer _ = iamResponseConsumer (const $ return PutUserPolicyResponse) instance Transaction PutUserPolicy PutUserPolicyResponse instance AsMemoryResponse PutUserPolicyResponse where type MemoryResponse PutUserPolicyResponse = PutUserPolicyResponse loadToMemory = return aws-0.13.0/Aws/DynamoDb/0000755000000000000000000000000012615132266013006 5ustar0000000000000000aws-0.13.0/Aws/DynamoDb/Commands.hs0000644000000000000000000000147612615132266015113 0ustar0000000000000000module Aws.DynamoDb.Commands ( module Aws.DynamoDb.Commands.DeleteItem , module Aws.DynamoDb.Commands.GetItem , module Aws.DynamoDb.Commands.PutItem , module Aws.DynamoDb.Commands.Query , module Aws.DynamoDb.Commands.Scan , module Aws.DynamoDb.Commands.Table , module Aws.DynamoDb.Commands.UpdateItem ) where ------------------------------------------------------------------------------- import Aws.DynamoDb.Commands.DeleteItem import Aws.DynamoDb.Commands.GetItem import Aws.DynamoDb.Commands.PutItem import Aws.DynamoDb.Commands.Query import Aws.DynamoDb.Commands.Scan import Aws.DynamoDb.Commands.Table import Aws.DynamoDb.Commands.UpdateItem ------------------------------------------------------------------------------- aws-0.13.0/Aws/DynamoDb/Core.hs0000644000000000000000000012040112615132266014230 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Aws.DynamoDb.Core -- Copyright : Soostone Inc, Chris Allen -- License : BSD3 -- -- Maintainer : Ozgun Ataman -- Stability : experimental -- -- Shared types and utilities for DyanmoDb functionality. ---------------------------------------------------------------------------- module Aws.DynamoDb.Core ( -- * Configuration and Regions Region (..) , ddbLocal , ddbUsEast1 , ddbUsWest1 , ddbUsWest2 , ddbEuWest1 , ddbEuCentral1 , ddbApNe1 , ddbApSe1 , ddbApSe2 , ddbSaEast1 , DdbConfiguration (..) -- * DynamoDB values , DValue (..) -- * Converting to/from 'DValue' , DynVal(..) , toValue, fromValue , Bin (..) , OldBool(..) -- * Defining new 'DynVal' instances , DynData(..) , DynBinary(..), DynNumber(..), DynString(..) -- * Working with key/value pairs , Attribute (..) , parseAttributeJson , attributeJson , attributesJson , attrTuple , attr , attrAs , text, int, double , PrimaryKey (..) , hk , hrk -- * Working with objects (attribute collections) , Item , item , attributes , ToDynItem (..) , FromDynItem (..) , fromItem , Parser (..) , getAttr , getAttr' -- * Common types used by operations , Conditions (..) , conditionsJson , expectsJson , Condition (..) , conditionJson , CondOp (..) , CondMerge (..) , ConsumedCapacity (..) , ReturnConsumption (..) , ItemCollectionMetrics (..) , ReturnItemCollectionMetrics (..) , UpdateReturn (..) , QuerySelect (..) , querySelectJson -- * Size estimation , DynSize (..) , nullAttr -- * Responses & Errors , DdbResponse (..) , DdbErrCode (..) , shouldRetry , DdbError (..) -- * Internal Helpers , ddbSignQuery , AmazonError (..) , ddbResponseConsumer , ddbHttp , ddbHttps ) where ------------------------------------------------------------------------------- import Control.Applicative import qualified Control.Exception as C import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Resource (throwM) import Crypto.Hash import Data.Aeson import qualified Data.Aeson as A import Data.Aeson.Types (Pair, parseEither) import qualified Data.Aeson.Types as A import qualified Data.Attoparsec.ByteString as AttoB (endOfInput) import qualified Data.Attoparsec.Text as Atto import Data.Byteable import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B import qualified Data.CaseInsensitive as CI import Data.Conduit import Data.Conduit.Attoparsec (sinkParser) import Data.Default import Data.Function (on) import qualified Data.HashMap.Strict as HM import Data.Int import Data.IORef import Data.List import qualified Data.Map as M import Data.Maybe import Data.Monoid import Data.Proxy import Data.Scientific import qualified Data.Serialize as Ser import qualified Data.Set as S import Data.String import Data.Tagged import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time import Data.Typeable import qualified Data.Vector as V import Data.Word import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import Safe ------------------------------------------------------------------------------- import Aws.Core ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- | Boolean values stored in DynamoDb. Only used in defining new -- 'DynVal' instances. newtype DynBool = DynBool { unDynBool :: Bool } deriving (Eq,Show,Read,Ord,Typeable) ------------------------------------------------------------------------------- -- | Numeric values stored in DynamoDb. Only used in defining new -- 'DynVal' instances. newtype DynNumber = DynNumber { unDynNumber :: Scientific } deriving (Eq,Show,Read,Ord,Typeable) ------------------------------------------------------------------------------- -- | String values stored in DynamoDb. Only used in defining new -- 'DynVal' instances. newtype DynString = DynString { unDynString :: T.Text } deriving (Eq,Show,Read,Ord,Typeable) ------------------------------------------------------------------------------- -- | Binary values stored in DynamoDb. Only used in defining new -- 'DynVal' instances. newtype DynBinary = DynBinary { unDynBinary :: B.ByteString } deriving (Eq,Show,Read,Ord,Typeable) ------------------------------------------------------------------------------- -- | An internally used closed typeclass for values that have direct -- DynamoDb representations. Based on AWS API, this is basically -- numbers, strings and binary blobs. -- -- This is here so that any 'DynVal' haskell value can automatically -- be lifted to a list or a 'Set' without any instance code -- duplication. -- -- Do not try to create your own instances. class Ord a => DynData a where fromData :: a -> DValue toData :: DValue -> Maybe a instance DynData DynBool where fromData (DynBool i) = DBool i toData (DBool i) = Just $ DynBool i toData (DNum i) = DynBool `fmap` do (i' :: Int) <- toIntegral i case i' of 0 -> return False 1 -> return True _ -> Nothing toData _ = Nothing instance DynData (S.Set DynBool) where fromData set = DBoolSet (S.map unDynBool set) toData (DBoolSet i) = Just $ S.map DynBool i toData _ = Nothing instance DynData DynNumber where fromData (DynNumber i) = DNum i toData (DNum i) = Just $ DynNumber i toData _ = Nothing instance DynData (S.Set DynNumber) where fromData set = DNumSet (S.map unDynNumber set) toData (DNumSet i) = Just $ S.map DynNumber i toData _ = Nothing instance DynData DynString where fromData (DynString i) = DString i toData (DString i) = Just $ DynString i toData _ = Nothing instance DynData (S.Set DynString) where fromData set = DStringSet (S.map unDynString set) toData (DStringSet i) = Just $ S.map DynString i toData _ = Nothing instance DynData DynBinary where fromData (DynBinary i) = DBinary i toData (DBinary i) = Just $ DynBinary i toData _ = Nothing instance DynData (S.Set DynBinary) where fromData set = DBinSet (S.map unDynBinary set) toData (DBinSet i) = Just $ S.map DynBinary i toData _ = Nothing instance DynData DValue where fromData = id toData = Just ------------------------------------------------------------------------------- -- | Class of Haskell types that can be represented as DynamoDb values. -- -- This is the conversion layer; instantiate this class for your own -- types and then use the 'toValue' and 'fromValue' combinators to -- convert in application code. -- -- Each Haskell type instantiated with this class will map to a -- DynamoDb-supported type that most naturally represents it. class DynData (DynRep a) => DynVal a where -- | Which of the 'DynData' instances does this data type directly -- map to? type DynRep a -- | Convert to representation toRep :: a -> DynRep a -- | Convert from representation fromRep :: DynRep a -> Maybe a ------------------------------------------------------------------------------- -- | Any singular 'DynVal' can be upgraded to a list. instance (DynData (DynRep [a]), DynVal a) => DynVal [a] where type DynRep [a] = S.Set (DynRep a) fromRep set = mapM fromRep $ S.toList set toRep as = S.fromList $ map toRep as ------------------------------------------------------------------------------- -- | Any singular 'DynVal' can be upgraded to a 'Set'. instance (DynData (DynRep (S.Set a)), DynVal a, Ord a) => DynVal (S.Set a) where type DynRep (S.Set a) = S.Set (DynRep a) fromRep set = fmap S.fromList . mapM fromRep $ S.toList set toRep as = S.map toRep as instance DynVal DValue where type DynRep DValue = DValue fromRep = Just toRep = id instance DynVal Bool where type DynRep Bool = DynBool fromRep (DynBool i) = Just i toRep i = DynBool i instance DynVal Int where type DynRep Int = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal Int8 where type DynRep Int8 = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal Int16 where type DynRep Int16 = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal Int32 where type DynRep Int32 = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal Int64 where type DynRep Int64 = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal Word8 where type DynRep Word8 = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal Word16 where type DynRep Word16 = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal Word32 where type DynRep Word32 = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal Word64 where type DynRep Word64 = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal Integer where type DynRep Integer = DynNumber fromRep (DynNumber i) = toIntegral i toRep i = DynNumber (fromIntegral i) instance DynVal T.Text where type DynRep T.Text = DynString fromRep (DynString i) = Just i toRep i = DynString i instance DynVal B.ByteString where type DynRep B.ByteString = DynBinary fromRep (DynBinary i) = Just i toRep i = DynBinary i instance DynVal Double where type DynRep Double = DynNumber fromRep (DynNumber i) = Just $ toRealFloat i toRep i = DynNumber (fromFloatDigits i) ------------------------------------------------------------------------------- -- | Encoded as number of days instance DynVal Day where type DynRep Day = DynNumber fromRep (DynNumber i) = ModifiedJulianDay <$> (toIntegral i) toRep (ModifiedJulianDay i) = DynNumber (fromIntegral i) ------------------------------------------------------------------------------- -- | Losslessly encoded via 'Integer' picoseconds instance DynVal UTCTime where type DynRep UTCTime = DynNumber fromRep num = fromTS <$> fromRep num toRep x = toRep (toTS x) ------------------------------------------------------------------------------- pico :: Rational pico = toRational $ 10 ^ (12 :: Integer) ------------------------------------------------------------------------------- dayPico :: Integer dayPico = 86400 * round pico ------------------------------------------------------------------------------- -- | Convert UTCTime to picoseconds -- -- TODO: Optimize performance? toTS :: UTCTime -> Integer toTS (UTCTime (ModifiedJulianDay i) diff) = i' + diff' where diff' = floor (toRational diff * pico) i' = i * dayPico ------------------------------------------------------------------------------- -- | Convert picoseconds to UTCTime -- -- TODO: Optimize performance? fromTS :: Integer -> UTCTime fromTS i = UTCTime (ModifiedJulianDay days) diff where (days, secs) = i `divMod` dayPico diff = fromRational ((toRational secs) / pico) -- | Type wrapper for binary data to be written to DynamoDB. Wrap any -- 'Serialize' instance in there and 'DynVal' will know how to -- automatically handle conversions in binary form. newtype Bin a = Bin { getBin :: a } deriving (Eq,Show,Read,Ord,Typeable,Enum) instance (Ser.Serialize a) => DynVal (Bin a) where type DynRep (Bin a) = DynBinary toRep (Bin i) = DynBinary (Ser.encode i) fromRep (DynBinary i) = either (const Nothing) (Just . Bin) $ Ser.decode i newtype OldBool = OldBool Bool instance DynVal OldBool where type DynRep OldBool = DynNumber fromRep (DynNumber i) = OldBool `fmap` do (i' :: Int) <- toIntegral i case i' of 0 -> return False 1 -> return True _ -> Nothing toRep (OldBool b) = DynNumber (if b then 1 else 0) ------------------------------------------------------------------------------- -- | Encode a Haskell value. toValue :: DynVal a => a -> DValue toValue a = fromData $ toRep a ------------------------------------------------------------------------------- -- | Decode a Haskell value. fromValue :: DynVal a => DValue -> Maybe a fromValue d = toData d >>= fromRep toIntegral :: (Integral a, RealFrac a1) => a1 -> Maybe a toIntegral sc = Just $ floor sc -- | Value types natively recognized by DynamoDb. We pretty much -- exactly reflect the AWS API onto Haskell types. data DValue = DNull | DNum Scientific | DString T.Text | DBinary B.ByteString -- ^ Binary data will automatically be base64 marshalled. | DNumSet (S.Set Scientific) | DStringSet (S.Set T.Text) | DBinSet (S.Set B.ByteString) -- ^ Binary data will automatically be base64 marshalled. | DBool Bool | DBoolSet (S.Set Bool) -- ^ Composite data | DList (V.Vector DValue) | DMap (M.Map T.Text DValue) deriving (Eq,Show,Read,Ord,Typeable) instance IsString DValue where fromString t = DString (T.pack t) ------------------------------------------------------------------------------- -- | Primary keys consist of either just a Hash key (mandatory) or a -- hash key and a range key (optional). data PrimaryKey = PrimaryKey { pkHash :: Attribute , pkRange :: Maybe Attribute } deriving (Read,Show,Ord,Eq,Typeable) ------------------------------------------------------------------------------- -- | Construct a hash-only primary key. -- -- >>> hk "user-id" "ABCD" -- -- >>> hk "user-id" (mkVal 23) hk :: T.Text -> DValue -> PrimaryKey hk k v = PrimaryKey (attr k v) Nothing ------------------------------------------------------------------------------- -- | Construct a hash-and-range primary key. hrk :: T.Text -- ^ Hash key name -> DValue -- ^ Hash key value -> T.Text -- ^ Range key name -> DValue -- ^ Range key value -> PrimaryKey hrk k v k2 v2 = PrimaryKey (attr k v) (Just (attr k2 v2)) instance ToJSON PrimaryKey where toJSON (PrimaryKey h Nothing) = toJSON h toJSON (PrimaryKey h (Just r)) = let Object p1 = toJSON h Object p2 = toJSON r in Object (p1 `HM.union` p2) -- | A key-value pair data Attribute = Attribute { attrName :: T.Text , attrVal :: DValue } deriving (Read,Show,Ord,Eq,Typeable) -- | Convert attribute to a tuple representation attrTuple :: Attribute -> (T.Text, DValue) attrTuple (Attribute a b) = (a,b) -- | Convenience function for constructing key-value pairs attr :: DynVal a => T.Text -> a -> Attribute attr k v = Attribute k (toValue v) -- | 'attr' with type witness to help with cases where you're manually -- supplying values in code. -- -- >> item [ attrAs text "name" "john" ] attrAs :: DynVal a => Proxy a -> T.Text -> a -> Attribute attrAs _ k v = attr k v -- | Type witness for 'Text'. See 'attrAs'. text :: Proxy T.Text text = Proxy -- | Type witness for 'Integer'. See 'attrAs'. int :: Proxy Integer int = Proxy -- | Type witness for 'Double'. See 'attrAs'. double :: Proxy Double double = Proxy -- | A DynamoDb object is simply a key-value dictionary. type Item = M.Map T.Text DValue ------------------------------------------------------------------------------- -- | Pack a list of attributes into an Item. item :: [Attribute] -> Item item = M.fromList . map attrTuple ------------------------------------------------------------------------------- -- | Unpack an 'Item' into a list of attributes. attributes :: M.Map T.Text DValue -> [Attribute] attributes = map (\ (k, v) -> Attribute k v) . M.toList showT :: Show a => a -> T.Text showT = T.pack . show instance ToJSON DValue where toJSON DNull = object ["NULL" .= True] toJSON (DNum i) = object ["N" .= showT i] toJSON (DString i) = object ["S" .= i] toJSON (DBinary i) = object ["B" .= (T.decodeUtf8 $ Base64.encode i)] toJSON (DNumSet i) = object ["NS" .= map showT (S.toList i)] toJSON (DStringSet i) = object ["SS" .= S.toList i] toJSON (DBinSet i) = object ["BS" .= map (T.decodeUtf8 . Base64.encode) (S.toList i)] toJSON (DBool i) = object ["BOOL" .= i] toJSON (DList i) = object ["L" .= i] toJSON (DMap i) = object ["M" .= i] toJSON x = error $ "aws: bug: DynamoDB can't handle " ++ show x instance FromJSON DValue where parseJSON o = do (obj :: [(T.Text, Value)]) <- M.toList `liftM` parseJSON o case obj of [("NULL", _)] -> return DNull [("N", numStr)] -> DNum <$> parseScientific numStr [("S", str)] -> DString <$> parseJSON str [("B", bin)] -> do res <- (Base64.decode . T.encodeUtf8) <$> parseJSON bin either fail (return . DBinary) res [("NS", s)] -> do xs <- mapM parseScientific =<< parseJSON s return $ DNumSet $ S.fromList xs [("SS", s)] -> DStringSet <$> parseJSON s [("BS", s)] -> do xs <- mapM (either fail return . Base64.decode . T.encodeUtf8) =<< parseJSON s return $ DBinSet $ S.fromList xs [("BOOL", b)] -> DBool <$> parseJSON b [("L", attrs)] -> DList <$> parseJSON attrs [("M", attrs)] -> DMap <$> parseJSON attrs x -> fail $ "aws: unknown dynamodb value: " ++ show x where parseScientific (String str) = case Atto.parseOnly Atto.scientific str of Left e -> fail ("parseScientific failed: " ++ e) Right a -> return a parseScientific (Number n) = return n parseScientific _ = fail "Unexpected JSON type in parseScientific" instance ToJSON Attribute where toJSON a = object $ [attributeJson a] ------------------------------------------------------------------------------- -- | Parse a JSON object that contains attributes parseAttributeJson :: Value -> A.Parser [Attribute] parseAttributeJson (Object v) = mapM conv $ HM.toList v where conv (k, o) = Attribute k <$> parseJSON o parseAttributeJson _ = error "Attribute JSON must be an Object" -- | Convert into JSON object for AWS. attributesJson :: [Attribute] -> Value attributesJson as = object $ map attributeJson as -- | Convert into JSON pair attributeJson :: Attribute -> Pair attributeJson (Attribute nm v) = nm .= v ------------------------------------------------------------------------------- -- | Errors defined by AWS. data DdbErrCode = AccessDeniedException | ConditionalCheckFailedException | IncompleteSignatureException | InvalidSignatureException | LimitExceededException | MissingAuthenticationTokenException | ProvisionedThroughputExceededException | ResourceInUseException | ResourceNotFoundException | ThrottlingException | ValidationException | RequestTooLarge | InternalFailure | InternalServerError | ServiceUnavailableException | SerializationException -- ^ Raised by AWS when the request JSON is missing fields or is -- somehow malformed. deriving (Read,Show,Eq,Typeable) ------------------------------------------------------------------------------- -- | Whether the action should be retried based on the received error. shouldRetry :: DdbErrCode -> Bool shouldRetry e = go e where go LimitExceededException = True go ProvisionedThroughputExceededException = True go ResourceInUseException = True go ThrottlingException = True go InternalFailure = True go InternalServerError = True go ServiceUnavailableException = True go _ = False ------------------------------------------------------------------------------- -- | Errors related to this library. data DdbLibraryError = UnknownDynamoErrCode T.Text -- ^ A DynamoDB error code we do not know about. | JsonProtocolError Value T.Text -- ^ A JSON response we could not parse. deriving (Show,Eq,Typeable) -- | Potential errors raised by DynamoDB data DdbError = DdbError { ddbStatusCode :: Int -- ^ 200 if successful, 400 for client errors and 500 for -- server-side errors. , ddbErrCode :: DdbErrCode , ddbErrMsg :: T.Text } deriving (Show,Eq,Typeable) instance C.Exception DdbError instance C.Exception DdbLibraryError -- | Response metadata that is present in every DynamoDB response. data DdbResponse = DdbResponse { ddbrCrc :: Maybe T.Text , ddbrMsgId :: Maybe T.Text } instance Loggable DdbResponse where toLogText (DdbResponse id2 rid) = "DynamoDB: request ID=" `mappend` fromMaybe "" rid `mappend` ", x-amz-id-2=" `mappend` fromMaybe "" id2 instance Monoid DdbResponse where mempty = DdbResponse Nothing Nothing mappend a b = DdbResponse (ddbrCrc a `mplus` ddbrCrc b) (ddbrMsgId a `mplus` ddbrMsgId b) data Region = Region { rUri :: B.ByteString , rName :: B.ByteString } deriving (Eq,Show,Read,Typeable) data DdbConfiguration qt = DdbConfiguration { ddbcRegion :: Region -- ^ The regional endpoint. Ex: 'ddbUsEast' , ddbcProtocol :: Protocol -- ^ 'HTTP' or 'HTTPS' , ddbcPort :: Maybe Int -- ^ Port override (mostly for local dev connection) } deriving (Show,Typeable) instance Default (DdbConfiguration NormalQuery) where def = DdbConfiguration ddbUsEast1 HTTPS Nothing instance DefaultServiceConfiguration (DdbConfiguration NormalQuery) where defServiceConfig = ddbHttps ddbUsEast1 debugServiceConfig = ddbHttp ddbUsEast1 ------------------------------------------------------------------------------- -- | DynamoDb local connection (for development) ddbLocal :: Region ddbLocal = Region "127.0.0.1" "local" ddbUsEast1 :: Region ddbUsEast1 = Region "dynamodb.us-east-1.amazonaws.com" "us-east-1" ddbUsWest1 :: Region ddbUsWest1 = Region "dynamodb.us-west-1.amazonaws.com" "us-west-1" ddbUsWest2 :: Region ddbUsWest2 = Region "dynamodb.us-west-2.amazonaws.com" "us-west-2" ddbEuWest1 :: Region ddbEuWest1 = Region "dynamodb.eu-west-1.amazonaws.com" "eu-west-1" ddbEuCentral1 :: Region ddbEuCentral1 = Region "dynamodb.eu-central-1.amazonaws.com" "eu-central-1" ddbApNe1 :: Region ddbApNe1 = Region "dynamodb.ap-northeast-1.amazonaws.com" "ap-northeast-1" ddbApSe1 :: Region ddbApSe1 = Region "dynamodb.ap-southeast-1.amazonaws.com" "ap-southeast-1" ddbApSe2 :: Region ddbApSe2 = Region "dynamodb.ap-southeast-2.amazonaws.com" "ap-southeast-2" ddbSaEast1 :: Region ddbSaEast1 = Region "dynamodb.sa-east-1.amazonaws.com" "sa-east-1" ddbHttp :: Region -> DdbConfiguration NormalQuery ddbHttp endpoint = DdbConfiguration endpoint HTTP Nothing ddbHttps :: Region -> DdbConfiguration NormalQuery ddbHttps endpoint = DdbConfiguration endpoint HTTPS Nothing ddbSignQuery :: A.ToJSON a => B.ByteString -> a -> DdbConfiguration qt -> SignatureData -> SignedQuery ddbSignQuery target body di sd = SignedQuery { sqMethod = Post , sqProtocol = ddbcProtocol di , sqHost = host , sqPort = fromMaybe (defaultPort (ddbcProtocol di)) (ddbcPort di) , sqPath = "/" , sqQuery = [] , sqDate = Just $ signatureTime sd , sqAuthorization = Just auth , sqContentType = Just "application/x-amz-json-1.0" , sqContentMd5 = Nothing , sqAmzHeaders = amzHeaders ++ maybe [] (\tok -> [("x-amz-security-token",tok)]) (iamToken credentials) , sqOtherHeaders = [] , sqBody = Just $ HTTP.RequestBodyLBS bodyLBS , sqStringToSign = canonicalRequest } where credentials = signatureCredentials sd Region{..} = ddbcRegion di host = rUri sigTime = fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd bodyLBS = A.encode body bodyHash = Base16.encode $ toBytes (hashlazy bodyLBS :: Digest SHA256) -- for some reason AWS doesn't want the x-amz-security-token in the canonical request amzHeaders = [ ("x-amz-date", sigTime) , ("x-amz-target", dyApiVersion <> target) ] canonicalHeaders = sortBy (compare `on` fst) $ amzHeaders ++ [("host", host), ("content-type", "application/x-amz-json-1.0")] canonicalRequest = B.concat $ intercalate ["\n"] ( [ ["POST"] , ["/"] , [] -- query string ] ++ map (\(a,b) -> [CI.foldedCase a,":",b]) canonicalHeaders ++ [ [] -- end headers , intersperse ";" (map (CI.foldedCase . fst) canonicalHeaders) , [bodyHash] ]) auth = authorizationV4 sd HmacSHA256 rName "dynamodb" "content-type;host;x-amz-date;x-amz-target" canonicalRequest data AmazonError = AmazonError { aeType :: T.Text , aeMessage :: Maybe T.Text } instance FromJSON AmazonError where parseJSON (Object v) = AmazonError <$> v .: "__type" <*> (Just <$> (v .: "message" <|> v .: "Message") <|> pure Nothing) parseJSON _ = error $ "aws: unexpected AmazonError message" ------------------------------------------------------------------------------- ddbResponseConsumer :: A.FromJSON a => IORef DdbResponse -> HTTPResponseConsumer a ddbResponseConsumer ref resp = do val <- HTTP.responseBody resp $$+- sinkParser (A.json' <* AttoB.endOfInput) case statusCode of 200 -> rSuccess val _ -> rError val where header = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp) amzId = header "x-amzn-RequestId" amzCrc = header "x-amz-crc32" meta = DdbResponse amzCrc amzId tellMeta = liftIO $ tellMetadataRef ref meta rSuccess val = case A.fromJSON val of A.Success a -> return a A.Error err -> do tellMeta throwM $ JsonProtocolError val (T.pack err) rError val = do tellMeta case parseEither parseJSON val of Left e -> throwM $ JsonProtocolError val (T.pack e) Right err'' -> do let e = T.drop 1 . snd . T.breakOn "#" $ aeType err'' errCode <- readErrCode e throwM $ DdbError statusCode errCode (fromMaybe "" $ aeMessage err'') readErrCode txt = let txt' = T.unpack txt in case readMay txt' of Just e -> return $ e Nothing -> throwM (UnknownDynamoErrCode txt) HTTP.Status{..} = HTTP.responseStatus resp -- | Conditions used by mutation operations ('PutItem', 'UpdateItem', -- etc.). The default 'def' instance is empty (no condition). data Conditions = Conditions CondMerge [Condition] deriving (Eq,Show,Read,Ord,Typeable) instance Default Conditions where def = Conditions CondAnd [] expectsJson :: Conditions -> [A.Pair] expectsJson = conditionsJson "Expected" -- | JSON encoding of conditions parameter in various contexts. conditionsJson :: T.Text -> Conditions -> [A.Pair] conditionsJson key (Conditions op es) = b ++ a where a = if null es then [] else [key .= object (map conditionJson es)] b = if length (take 2 es) > 1 then ["ConditionalOperator" .= String (rendCondOp op) ] else [] ------------------------------------------------------------------------------- rendCondOp :: CondMerge -> T.Text rendCondOp CondAnd = "AND" rendCondOp CondOr = "OR" ------------------------------------------------------------------------------- -- | How to merge multiple conditions. data CondMerge = CondAnd | CondOr deriving (Eq,Show,Read,Ord,Typeable) -- | A condition used by mutation operations ('PutItem', 'UpdateItem', etc.). data Condition = Condition { condAttr :: T.Text -- ^ Attribute to use as the basis for this conditional , condOp :: CondOp -- ^ Operation on the selected attribute } deriving (Eq,Show,Read,Ord,Typeable) ------------------------------------------------------------------------------- -- | Conditional operation to perform on a field. data CondOp = DEq DValue | NotEq DValue | DLE DValue | DLT DValue | DGE DValue | DGT DValue | NotNull | IsNull | Contains DValue | NotContains DValue | Begins DValue | In [DValue] | Between DValue DValue deriving (Eq,Show,Read,Ord,Typeable) ------------------------------------------------------------------------------- getCondValues :: CondOp -> [DValue] getCondValues c = case c of DEq v -> [v] NotEq v -> [v] DLE v -> [v] DLT v -> [v] DGE v -> [v] DGT v -> [v] NotNull -> [] IsNull -> [] Contains v -> [v] NotContains v -> [v] Begins v -> [v] In v -> v Between a b -> [a,b] ------------------------------------------------------------------------------- renderCondOp :: CondOp -> T.Text renderCondOp c = case c of DEq{} -> "EQ" NotEq{} -> "NE" DLE{} -> "LE" DLT{} -> "LT" DGE{} -> "GE" DGT{} -> "GT" NotNull -> "NOT_NULL" IsNull -> "NULL" Contains{} -> "CONTAINS" NotContains{} -> "NOT_CONTAINS" Begins{} -> "BEGINS_WITH" In{} -> "IN" Between{} -> "BETWEEN" conditionJson :: Condition -> Pair conditionJson Condition{..} = condAttr .= condOp instance ToJSON CondOp where toJSON c = object $ ("ComparisonOperator" .= String (renderCondOp c)) : valueList where valueList = let vs = getCondValues c in if null vs then [] else ["AttributeValueList" .= vs] ------------------------------------------------------------------------------- dyApiVersion :: B.ByteString dyApiVersion = "DynamoDB_20120810." ------------------------------------------------------------------------------- -- | The standard response metrics on capacity consumption. data ConsumedCapacity = ConsumedCapacity { capacityUnits :: Int64 , capacityGlobalIndex :: [(T.Text, Int64)] , capacityLocalIndex :: [(T.Text, Int64)] , capacityTableUnits :: Maybe Int64 , capacityTable :: T.Text } deriving (Eq,Show,Read,Ord,Typeable) instance FromJSON ConsumedCapacity where parseJSON (Object v) = ConsumedCapacity <$> v .: "CapacityUnits" <*> (HM.toList <$> v .:? "GlobalSecondaryIndexes" .!= mempty) <*> (HM.toList <$> v .:? "LocalSecondaryIndexes" .!= mempty) <*> (v .:? "Table" >>= maybe (return Nothing) (.: "CapacityUnits")) <*> v .: "TableName" parseJSON _ = fail "ConsumedCapacity must be an Object." data ReturnConsumption = RCIndexes | RCTotal | RCNone deriving (Eq,Show,Read,Ord,Typeable) instance ToJSON ReturnConsumption where toJSON RCIndexes = String "INDEXES" toJSON RCTotal = String "TOTAL" toJSON RCNone = String "NONE" instance Default ReturnConsumption where def = RCNone data ReturnItemCollectionMetrics = RICMSize | RICMNone deriving (Eq,Show,Read,Ord,Typeable) instance ToJSON ReturnItemCollectionMetrics where toJSON RICMSize = String "SIZE" toJSON RICMNone = String "NONE" instance Default ReturnItemCollectionMetrics where def = RICMNone data ItemCollectionMetrics = ItemCollectionMetrics { icmKey :: (T.Text, DValue) , icmEstimate :: [Double] } deriving (Eq,Show,Read,Ord,Typeable) instance FromJSON ItemCollectionMetrics where parseJSON (Object v) = ItemCollectionMetrics <$> (do m <- v .: "ItemCollectionKey" return $ head $ HM.toList m) <*> v .: "SizeEstimateRangeGB" parseJSON _ = fail "ItemCollectionMetrics must be an Object." ------------------------------------------------------------------------------- -- | What to return from the current update operation data UpdateReturn = URNone -- ^ Return nothing | URAllOld -- ^ Return old values | URUpdatedOld -- ^ Return old values with a newer replacement | URAllNew -- ^ Return new values | URUpdatedNew -- ^ Return new values that were replacements deriving (Eq,Show,Read,Ord,Typeable) instance ToJSON UpdateReturn where toJSON URNone = toJSON (String "NONE") toJSON URAllOld = toJSON (String "ALL_OLD") toJSON URUpdatedOld = toJSON (String "UPDATED_OLD") toJSON URAllNew = toJSON (String "ALL_NEW") toJSON URUpdatedNew = toJSON (String "UPDATED_NEW") instance Default UpdateReturn where def = URNone ------------------------------------------------------------------------------- -- | What to return from a 'Query' or 'Scan' query. data QuerySelect = SelectSpecific [T.Text] -- ^ Only return selected attributes | SelectCount -- ^ Return counts instead of attributes | SelectProjected -- ^ Return index-projected attributes | SelectAll -- ^ Default. Return everything. deriving (Eq,Show,Read,Ord,Typeable) instance Default QuerySelect where def = SelectAll ------------------------------------------------------------------------------- querySelectJson (SelectSpecific as) = [ "Select" .= String "SPECIFIC_ATTRIBUTES" , "AttributesToGet" .= as] querySelectJson SelectCount = ["Select" .= String "COUNT"] querySelectJson SelectProjected = ["Select" .= String "ALL_PROJECTED_ATTRIBUTES"] querySelectJson SelectAll = ["Select" .= String "ALL_ATTRIBUTES"] ------------------------------------------------------------------------------- -- | A class to help predict DynamoDb size of values, attributes and -- entire items. The result is given in number of bytes. class DynSize a where dynSize :: a -> Int instance DynSize DValue where dynSize DNull = 8 dynSize (DBool _) = 8 dynSize (DBoolSet s) = sum $ map (dynSize . DBool) $ S.toList s dynSize (DNum _) = 8 dynSize (DString a) = T.length a dynSize (DBinary bs) = T.length . T.decodeUtf8 $ Base64.encode bs dynSize (DNumSet s) = 8 * S.size s dynSize (DStringSet s) = sum $ map (dynSize . DString) $ S.toList s dynSize (DBinSet s) = sum $ map (dynSize . DBinary) $ S.toList s dynSize (DList s) = sum $ map dynSize $ V.toList s dynSize (DMap s) = sum $ map dynSize $ M.elems s instance DynSize Attribute where dynSize (Attribute k v) = T.length k + dynSize v instance DynSize Item where dynSize m = sum $ map dynSize $ attributes m instance DynSize a => DynSize [a] where dynSize as = sum $ map dynSize as instance DynSize a => DynSize (Maybe a) where dynSize = maybe 0 dynSize instance (DynSize a, DynSize b) => DynSize (Either a b) where dynSize = either dynSize dynSize ------------------------------------------------------------------------------- -- | Will an attribute be considered empty by DynamoDb? -- -- A 'PutItem' (or similar) with empty attributes will be rejected -- with a 'ValidationException'. nullAttr :: Attribute -> Bool nullAttr (Attribute _ val) = case val of DString "" -> True DBinary "" -> True DNumSet s | S.null s -> True DStringSet s | S.null s -> True DBinSet s | S.null s -> True _ -> False ------------------------------------------------------------------------------- -- -- | Item Parsing -- ------------------------------------------------------------------------------- -- | Failure continuation. type Failure f r = String -> f r -- | Success continuation. type Success a f r = a -> f r -- | A continuation-based parser type. newtype Parser a = Parser { runParser :: forall f r. Failure f r -> Success a f r -> f r } instance Monad Parser where m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks in runParser m kf ks' {-# INLINE (>>=) #-} return a = Parser $ \_kf ks -> ks a {-# INLINE return #-} fail msg = Parser $ \kf _ks -> kf msg {-# INLINE fail #-} instance Functor Parser where fmap f m = Parser $ \kf ks -> let ks' a = ks (f a) in runParser m kf ks' {-# INLINE fmap #-} instance Applicative Parser where pure = return {-# INLINE pure #-} (<*>) = apP {-# INLINE (<*>) #-} instance Alternative Parser where empty = fail "empty" {-# INLINE empty #-} (<|>) = mplus {-# INLINE (<|>) #-} instance MonadPlus Parser where mzero = fail "mzero" {-# INLINE mzero #-} mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks in runParser a kf' ks {-# INLINE mplus #-} instance Monoid (Parser a) where mempty = fail "mempty" {-# INLINE mempty #-} mappend = mplus {-# INLINE mappend #-} apP :: Parser (a -> b) -> Parser a -> Parser b apP d e = do b <- d a <- e return (b a) {-# INLINE apP #-} ------------------------------------------------------------------------------- -- | Types convertible to DynamoDb 'Item' collections. -- -- Use 'attr' and 'attrAs' combinators to conveniently define instances. class ToDynItem a where toItem :: a -> Item ------------------------------------------------------------------------------- -- | Types parseable from DynamoDb 'Item' collections. -- -- User 'getAttr' family of functions to applicatively or monadically -- parse into your custom types. class FromDynItem a where parseItem :: Item -> Parser a instance ToDynItem Item where toItem = id instance FromDynItem Item where parseItem = return instance DynVal a => ToDynItem [(T.Text, a)] where toItem as = item $ map (uncurry attr) as instance (Typeable a, DynVal a) => FromDynItem [(T.Text, a)] where parseItem i = mapM f $ M.toList i where f (k,v) = do v' <- maybe (fail (valErr (Tagged v :: Tagged a DValue))) return $ fromValue v return (k, v') instance DynVal a => ToDynItem (M.Map T.Text a) where toItem m = toItem $ M.toList m instance (Typeable a, DynVal a) => FromDynItem (M.Map T.Text a) where parseItem i = M.fromList <$> parseItem i valErr :: forall a. Typeable a => Tagged a DValue -> String valErr (Tagged dv) = "Can't convert DynamoDb value " <> show dv <> " into type " <> (show (typeOf (undefined :: a))) -- | Convenience combinator for parsing fields from an 'Item' returned -- by DynamoDb. getAttr :: forall a. (Typeable a, DynVal a) => T.Text -- ^ Attribute name -> Item -- ^ Item from DynamoDb -> Parser a getAttr k m = do case M.lookup k m of Nothing -> fail ("Key " <> T.unpack k <> " not found") Just dv -> maybe (fail (valErr (Tagged dv :: Tagged a DValue))) return $ fromValue dv -- | Parse attribute if it's present in the 'Item'. Fail if attribute -- is present but conversion fails. getAttr' :: forall a. (Typeable a, DynVal a) => T.Text -- ^ Attribute name -> Item -- ^ Item from DynamoDb -> Parser (Maybe a) getAttr' k m = do case M.lookup k m of Nothing -> return Nothing Just dv -> return $ fromValue dv ------------------------------------------------------------------------------- -- | Parse an 'Item' into target type using the 'FromDynItem' -- instance. fromItem :: FromDynItem a => Item -> Either String a fromItem i = runParser (parseItem i) Left Right aws-0.13.0/Aws/DynamoDb/Commands/0000755000000000000000000000000012615132266014547 5ustar0000000000000000aws-0.13.0/Aws/DynamoDb/Commands/DeleteItem.hs0000644000000000000000000000667112615132266017136 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Aws.DynamoDb.Commands.DeleteItem -- Copyright : Soostone Inc -- License : BSD3 -- -- Maintainer : Ozgun Ataman -- Stability : experimental -- -- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_DeleteItem.html@ ---------------------------------------------------------------------------- module Aws.DynamoDb.Commands.DeleteItem where ------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson import Data.Default import qualified Data.Text as T ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core ------------------------------------------------------------------------------- data DeleteItem = DeleteItem { diTable :: T.Text -- ^ Target table , diKey :: PrimaryKey -- ^ The item to delete. , diExpect :: Conditions -- ^ (Possible) set of expections for a conditional Put , diReturn :: UpdateReturn -- ^ What to return from this query. , diRetCons :: ReturnConsumption , diRetMet :: ReturnItemCollectionMetrics } deriving (Eq,Show,Read,Ord) ------------------------------------------------------------------------------- -- | Construct a minimal 'DeleteItem' request. deleteItem :: T.Text -- ^ A Dynamo table name -> PrimaryKey -- ^ Item to be saved -> DeleteItem deleteItem tn key = DeleteItem tn key def def def def instance ToJSON DeleteItem where toJSON DeleteItem{..} = object $ expectsJson diExpect ++ [ "TableName" .= diTable , "Key" .= diKey , "ReturnValues" .= diReturn , "ReturnConsumedCapacity" .= diRetCons , "ReturnItemCollectionMetrics" .= diRetMet ] data DeleteItemResponse = DeleteItemResponse { dirAttrs :: Maybe Item -- ^ Old attributes, if requested , dirConsumed :: Maybe ConsumedCapacity -- ^ Amount of capacity consumed , dirColMet :: Maybe ItemCollectionMetrics -- ^ Collection metrics if they have been requested. } deriving (Eq,Show,Read,Ord) instance Transaction DeleteItem DeleteItemResponse instance SignQuery DeleteItem where type ServiceConfiguration DeleteItem = DdbConfiguration signQuery gi = ddbSignQuery "DeleteItem" gi instance FromJSON DeleteItemResponse where parseJSON (Object v) = DeleteItemResponse <$> v .:? "Attributes" <*> v .:? "ConsumedCapacity" <*> v .:? "ItemCollectionMetrics" parseJSON _ = fail "DeleteItemResponse must be an object." instance ResponseConsumer r DeleteItemResponse where type ResponseMetadata DeleteItemResponse = DdbResponse responseConsumer _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse DeleteItemResponse where type MemoryResponse DeleteItemResponse = DeleteItemResponse loadToMemory = return aws-0.13.0/Aws/DynamoDb/Commands/PutItem.hs0000644000000000000000000000663512615132266016504 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Aws.DynamoDb.Commands.GetItem -- Copyright : Soostone Inc -- License : BSD3 -- -- Maintainer : Ozgun Ataman -- Stability : experimental -- -- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_PutItem.html@ ---------------------------------------------------------------------------- module Aws.DynamoDb.Commands.PutItem where ------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson import Data.Default import qualified Data.Text as T ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core ------------------------------------------------------------------------------- data PutItem = PutItem { piTable :: T.Text -- ^ Target table , piItem :: Item -- ^ An item to Put. Attributes here will replace what maybe under -- the key on DDB. , piExpect :: Conditions -- ^ (Possible) set of expections for a conditional Put , piReturn :: UpdateReturn -- ^ What to return from this query. , piRetCons :: ReturnConsumption , piRetMet :: ReturnItemCollectionMetrics } deriving (Eq,Show,Read,Ord) ------------------------------------------------------------------------------- -- | Construct a minimal 'PutItem' request. putItem :: T.Text -- ^ A Dynamo table name -> Item -- ^ Item to be saved -> PutItem putItem tn it = PutItem tn it def def def def instance ToJSON PutItem where toJSON PutItem{..} = object $ expectsJson piExpect ++ [ "TableName" .= piTable , "Item" .= piItem , "ReturnValues" .= piReturn , "ReturnConsumedCapacity" .= piRetCons , "ReturnItemCollectionMetrics" .= piRetMet ] data PutItemResponse = PutItemResponse { pirAttrs :: Maybe Item -- ^ Old attributes, if requested , pirConsumed :: Maybe ConsumedCapacity -- ^ Amount of capacity consumed , pirColMet :: Maybe ItemCollectionMetrics -- ^ Collection metrics if they have been requested. } deriving (Eq,Show,Read,Ord) instance Transaction PutItem PutItemResponse instance SignQuery PutItem where type ServiceConfiguration PutItem = DdbConfiguration signQuery gi = ddbSignQuery "PutItem" gi instance FromJSON PutItemResponse where parseJSON (Object v) = PutItemResponse <$> v .:? "Attributes" <*> v .:? "ConsumedCapacity" <*> v .:? "ItemCollectionMetrics" parseJSON _ = fail "PutItemResponse must be an object." instance ResponseConsumer r PutItemResponse where type ResponseMetadata PutItemResponse = DdbResponse responseConsumer _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse PutItemResponse where type MemoryResponse PutItemResponse = PutItemResponse loadToMemory = return aws-0.13.0/Aws/DynamoDb/Commands/Scan.hs0000644000000000000000000001031212615132266015764 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Aws.DynamoDb.Commands.Scan -- Copyright : Soostone Inc -- License : BSD3 -- -- Maintainer : Ozgun Ataman -- Stability : experimental -- -- Implementation of Amazon DynamoDb Scan command. -- -- See: @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_Scan.html@ ---------------------------------------------------------------------------- module Aws.DynamoDb.Commands.Scan ( Scan (..) , scan , ScanResponse (..) ) where ------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson import Data.Default import Data.Maybe import qualified Data.Text as T import Data.Typeable import qualified Data.Vector as V ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core ------------------------------------------------------------------------------- -- | A Scan command that uses primary keys for an expedient scan. data Scan = Scan { sTableName :: T.Text -- ^ Required. , sConsistentRead :: Bool -- ^ Whether to require a consistent read , sFilter :: Conditions -- ^ Whether to filter results before returning to client , sStartKey :: Maybe [Attribute] -- ^ Exclusive start key to resume a previous query. , sLimit :: Maybe Int -- ^ Whether to limit result set size , sIndex :: Maybe T.Text -- ^ Optional. Index to 'Scan' , sSelect :: QuerySelect -- ^ What to return from 'Scan' , sRetCons :: ReturnConsumption , sSegment :: Int -- ^ Segment number, starting at 0, for parallel queries. , sTotalSegments :: Int -- ^ Total number of parallel segments. 1 means sequential scan. } deriving (Eq,Show,Read,Ord,Typeable) -- | Construct a minimal 'Scan' request. scan :: T.Text -- ^ Table name -> Scan scan tn = Scan tn False def Nothing Nothing Nothing def def 0 1 -- | Response to a 'Scan' query. data ScanResponse = ScanResponse { srItems :: V.Vector Item , srLastKey :: Maybe [Attribute] , srCount :: Int , srScanned :: Int , srConsumed :: Maybe ConsumedCapacity } deriving (Eq,Show,Read,Ord) ------------------------------------------------------------------------------- instance ToJSON Scan where toJSON Scan{..} = object $ catMaybes [ (("ExclusiveStartKey" .= ) . attributesJson) <$> sStartKey , ("Limit" .= ) <$> sLimit , ("IndexName" .= ) <$> sIndex ] ++ conditionsJson "ScanFilter" sFilter ++ querySelectJson sSelect ++ [ "TableName".= sTableName , "ReturnConsumedCapacity" .= sRetCons , "Segment" .= sSegment , "TotalSegments" .= sTotalSegments , "ConsistentRead" .= sConsistentRead ] instance FromJSON ScanResponse where parseJSON (Object v) = ScanResponse <$> v .:? "Items" .!= V.empty <*> ((do o <- v .: "LastEvaluatedKey" Just <$> parseAttributeJson o) <|> pure Nothing) <*> v .: "Count" <*> v .: "ScannedCount" <*> v .:? "ConsumedCapacity" parseJSON _ = fail "ScanResponse must be an object." instance Transaction Scan ScanResponse instance SignQuery Scan where type ServiceConfiguration Scan = DdbConfiguration signQuery gi = ddbSignQuery "Scan" gi instance ResponseConsumer r ScanResponse where type ResponseMetadata ScanResponse = DdbResponse responseConsumer _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse ScanResponse where type MemoryResponse ScanResponse = ScanResponse loadToMemory = return instance ListResponse ScanResponse Item where listResponse = V.toList . srItems instance IteratedTransaction Scan ScanResponse where nextIteratedRequest request response = case srLastKey response of Nothing -> Nothing key -> Just request { sStartKey = key } aws-0.13.0/Aws/DynamoDb/Commands/Table.hs0000644000000000000000000004447412615132266016147 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} module Aws.DynamoDb.Commands.Table ( -- * Commands CreateTable(..) , createTable , CreateTableResult(..) , DescribeTable(..) , DescribeTableResult(..) , UpdateTable(..) , UpdateTableResult(..) , DeleteTable(..) , DeleteTableResult(..) , ListTables(..) , ListTablesResult(..) -- * Data passed in the commands , AttributeType(..) , AttributeDefinition(..) , KeySchema(..) , Projection(..) , LocalSecondaryIndex(..) , LocalSecondaryIndexStatus(..) , ProvisionedThroughput(..) , ProvisionedThroughputStatus(..) , GlobalSecondaryIndex(..) , GlobalSecondaryIndexStatus(..) , GlobalSecondaryIndexUpdate(..) , TableDescription(..) ) where ------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson ((.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import Data.Char (toUpper) import qualified Data.HashMap.Strict as M import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import Data.Typeable import qualified Data.Vector as V import GHC.Generics (Generic) ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core ------------------------------------------------------------------------------- capitalizeOpt :: A.Options capitalizeOpt = A.defaultOptions { A.fieldLabelModifier = \x -> case x of (c:cs) -> toUpper c : cs [] -> [] } dropOpt :: Int -> A.Options dropOpt d = A.defaultOptions { A.fieldLabelModifier = drop d } -- | The type of a key attribute that appears in the table key or as a -- key in one of the indices. data AttributeType = AttrString | AttrNumber | AttrBinary deriving (Show, Read, Ord, Typeable, Eq, Enum, Bounded, Generic) instance A.ToJSON AttributeType where toJSON AttrString = A.String "S" toJSON AttrNumber = A.String "N" toJSON AttrBinary = A.String "B" instance A.FromJSON AttributeType where parseJSON (A.String str) = case str of "S" -> return AttrString "N" -> return AttrNumber "B" -> return AttrBinary _ -> fail $ "Invalid attribute type " ++ T.unpack str parseJSON _ = fail "Attribute type must be a string" -- | A key attribute that appears in the table key or as a key in one of the indices. data AttributeDefinition = AttributeDefinition { attributeName :: T.Text , attributeType :: AttributeType } deriving (Eq,Read,Ord,Show,Typeable,Generic) instance A.ToJSON AttributeDefinition where toJSON = A.genericToJSON capitalizeOpt instance A.FromJSON AttributeDefinition where parseJSON = A.genericParseJSON capitalizeOpt -- | The key schema can either be a hash of a single attribute name or a hash attribute name -- and a range attribute name. data KeySchema = HashOnly T.Text | HashAndRange T.Text T.Text deriving (Eq,Read,Show,Ord,Typeable,Generic) instance A.ToJSON KeySchema where toJSON (HashOnly a) = A.Array $ V.fromList [ A.object [ "AttributeName" .= a , "KeyType" .= (A.String "HASH") ] ] toJSON (HashAndRange hash range) = A.Array $ V.fromList [ A.object [ "AttributeName" .= hash , "KeyType" .= (A.String "HASH") ] , A.object [ "AttributeName" .= range , "KeyType" .= (A.String "RANGE") ] ] instance A.FromJSON KeySchema where parseJSON (A.Array v) = case V.length v of 1 -> do obj <- A.parseJSON (v V.! 0) kt <- obj .: "KeyType" if kt /= ("HASH" :: T.Text) then fail "With only one key, the type must be HASH" else HashOnly <$> obj .: "AttributeName" 2 -> do hash <- A.parseJSON (v V.! 0) range <- A.parseJSON (v V.! 1) hkt <- hash .: "KeyType" rkt <- range .: "KeyType" if hkt /= ("HASH" :: T.Text) || rkt /= ("RANGE" :: T.Text) then fail "With two keys, one must be HASH and the other RANGE" else HashAndRange <$> hash .: "AttributeName" <*> range .: "AttributeName" _ -> fail "Key schema must have one or two entries" parseJSON _ = fail "Key schema must be an array" -- | This determines which attributes are projected into a secondary index. data Projection = ProjectKeysOnly | ProjectAll | ProjectInclude [T.Text] deriving Show instance A.ToJSON Projection where toJSON ProjectKeysOnly = A.object [ "ProjectionType" .= ("KEYS_ONLY" :: T.Text) ] toJSON ProjectAll = A.object [ "ProjectionType" .= ("ALL" :: T.Text) ] toJSON (ProjectInclude a) = A.object [ "ProjectionType" .= ("INCLUDE" :: T.Text) , "NonKeyAttributes" .= a ] instance A.FromJSON Projection where parseJSON (A.Object o) = do ty <- (o .: "ProjectionType") :: A.Parser T.Text case ty of "KEYS_ONLY" -> return ProjectKeysOnly "ALL" -> return ProjectAll "INCLUDE" -> ProjectInclude <$> o .: "NonKeyAttributes" _ -> fail "Invalid projection type" parseJSON _ = fail "Projection must be an object" -- | Describes a single local secondary index. The KeySchema MUST -- share the same hash key attribute as the parent table, only the -- range key can differ. data LocalSecondaryIndex = LocalSecondaryIndex { localIndexName :: T.Text , localKeySchema :: KeySchema , localProjection :: Projection } deriving (Show, Generic) instance A.ToJSON LocalSecondaryIndex where toJSON = A.genericToJSON $ dropOpt 5 instance A.FromJSON LocalSecondaryIndex where parseJSON = A.genericParseJSON $ dropOpt 5 -- | This is returned by AWS to describe the local secondary index. data LocalSecondaryIndexStatus = LocalSecondaryIndexStatus { locStatusIndexName :: T.Text , locStatusIndexSizeBytes :: Integer , locStatusItemCount :: Integer , locStatusKeySchema :: KeySchema , locStatusProjection :: Projection } deriving (Show, Generic) instance A.FromJSON LocalSecondaryIndexStatus where parseJSON = A.genericParseJSON $ dropOpt 9 -- | The target provisioned throughput you are requesting for the table or global secondary index. data ProvisionedThroughput = ProvisionedThroughput { readCapacityUnits :: Int , writeCapacityUnits :: Int } deriving (Show, Generic) instance A.ToJSON ProvisionedThroughput where toJSON = A.genericToJSON capitalizeOpt instance A.FromJSON ProvisionedThroughput where parseJSON = A.genericParseJSON capitalizeOpt -- | This is returned by AWS as the status of the throughput for a table or global secondary index. data ProvisionedThroughputStatus = ProvisionedThroughputStatus { statusLastDecreaseDateTime :: UTCTime , statusLastIncreaseDateTime :: UTCTime , statusNumberOfDecreasesToday :: Int , statusReadCapacityUnits :: Int , statusWriteCapacityUnits :: Int } deriving (Show, Generic) instance A.FromJSON ProvisionedThroughputStatus where parseJSON = A.withObject "Throughput status must be an object" $ \o -> ProvisionedThroughputStatus <$> (posixSecondsToUTCTime . fromInteger <$> o .:? "LastDecreaseDateTime" .!= 0) <*> (posixSecondsToUTCTime . fromInteger <$> o .:? "LastIncreaseDateTime" .!= 0) <*> o .:? "NumberOfDecreasesToday" .!= 0 <*> o .: "ReadCapacityUnits" <*> o .: "WriteCapacityUnits" -- | Describes a global secondary index. data GlobalSecondaryIndex = GlobalSecondaryIndex { globalIndexName :: T.Text , globalKeySchema :: KeySchema , globalProjection :: Projection , globalProvisionedThroughput :: ProvisionedThroughput } deriving (Show, Generic) instance A.ToJSON GlobalSecondaryIndex where toJSON = A.genericToJSON $ dropOpt 6 instance A.FromJSON GlobalSecondaryIndex where parseJSON = A.genericParseJSON $ dropOpt 6 -- | This is returned by AWS to describe the status of a global secondary index. data GlobalSecondaryIndexStatus = GlobalSecondaryIndexStatus { gStatusIndexName :: T.Text , gStatusIndexSizeBytes :: Integer , gStatusIndexStatus :: T.Text , gStatusItemCount :: Integer , gStatusKeySchema :: KeySchema , gStatusProjection :: Projection , gStatusProvisionedThroughput :: ProvisionedThroughputStatus } deriving (Show, Generic) instance A.FromJSON GlobalSecondaryIndexStatus where parseJSON = A.genericParseJSON $ dropOpt 7 -- | This is used to request a change in the provisioned throughput of -- a global secondary index as part of an 'UpdateTable' operation. data GlobalSecondaryIndexUpdate = GlobalSecondaryIndexUpdate { gUpdateIndexName :: T.Text , gUpdateProvisionedThroughput :: ProvisionedThroughput } deriving (Show, Generic) instance A.ToJSON GlobalSecondaryIndexUpdate where toJSON gi = A.object ["Update" .= A.genericToJSON (dropOpt 7) gi] -- | This describes the table and is the return value from AWS for all -- the table-related commands. data TableDescription = TableDescription { rTableName :: T.Text , rTableSizeBytes :: Integer , rTableStatus :: T.Text -- ^ one of CREATING, UPDATING, DELETING, ACTIVE , rCreationDateTime :: Maybe UTCTime , rItemCount :: Integer , rAttributeDefinitions :: [AttributeDefinition] , rKeySchema :: Maybe KeySchema , rProvisionedThroughput :: ProvisionedThroughputStatus , rLocalSecondaryIndexes :: [LocalSecondaryIndexStatus] , rGlobalSecondaryIndexes :: [GlobalSecondaryIndexStatus] } deriving (Show, Generic) instance A.FromJSON TableDescription where parseJSON = A.withObject "Table must be an object" $ \o -> do t <- case (M.lookup "Table" o, M.lookup "TableDescription" o) of (Just (A.Object t), _) -> return t (_, Just (A.Object t)) -> return t _ -> fail "Table description must have key 'Table' or 'TableDescription'" TableDescription <$> t .: "TableName" <*> t .: "TableSizeBytes" <*> t .: "TableStatus" <*> (fmap (posixSecondsToUTCTime . fromInteger) <$> t .:? "CreationDateTime") <*> t .: "ItemCount" <*> t .:? "AttributeDefinitions" .!= [] <*> t .:? "KeySchema" <*> t .: "ProvisionedThroughput" <*> t .:? "LocalSecondaryIndexes" .!= [] <*> t .:? "GlobalSecondaryIndexes" .!= [] {- Can't derive these instances onto the return values instance ResponseConsumer r TableDescription where type ResponseMetadata TableDescription = DyMetadata responseConsumer _ _ = ddbResponseConsumer instance AsMemoryResponse TableDescription where type MemoryResponse TableDescription = TableDescription loadToMemory = return -} ------------------------------------------------------------------------------- --- Commands ------------------------------------------------------------------------------- data CreateTable = CreateTable { createTableName :: T.Text , createAttributeDefinitions :: [AttributeDefinition] -- ^ only attributes appearing in a key must be listed here , createKeySchema :: KeySchema , createProvisionedThroughput :: ProvisionedThroughput , createLocalSecondaryIndexes :: [LocalSecondaryIndex] -- ^ at most 5 local secondary indices are allowed , createGlobalSecondaryIndexes :: [GlobalSecondaryIndex] } deriving (Show, Generic) createTable :: T.Text -- ^ Table name -> [AttributeDefinition] -> KeySchema -> ProvisionedThroughput -> CreateTable createTable tn ad ks p = CreateTable tn ad ks p [] [] instance A.ToJSON CreateTable where toJSON ct = A.object $ m ++ lindex ++ gindex where m = [ "TableName" .= createTableName ct , "AttributeDefinitions" .= createAttributeDefinitions ct , "KeySchema" .= createKeySchema ct , "ProvisionedThroughput" .= createProvisionedThroughput ct ] -- AWS will error with 500 if (LocalSecondaryIndexes : []) is present in the JSON lindex = if null (createLocalSecondaryIndexes ct) then [] else [ "LocalSecondaryIndexes" .= createLocalSecondaryIndexes ct ] gindex = if null (createGlobalSecondaryIndexes ct) then [] else [ "GlobalSecondaryIndexes" .= createGlobalSecondaryIndexes ct ] --instance A.ToJSON CreateTable where -- toJSON = A.genericToJSON $ dropOpt 6 -- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery CreateTable where type ServiceConfiguration CreateTable = DdbConfiguration signQuery = ddbSignQuery "CreateTable" newtype CreateTableResult = CreateTableResult { ctStatus :: TableDescription } deriving (Show, A.FromJSON) -- ResponseConsumer and AsMemoryResponse can't be derived instance ResponseConsumer r CreateTableResult where type ResponseMetadata CreateTableResult = DdbResponse responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse CreateTableResult where type MemoryResponse CreateTableResult = TableDescription loadToMemory = return . ctStatus instance Transaction CreateTable CreateTableResult data DescribeTable = DescribeTable { dTableName :: T.Text } deriving (Show, Generic) instance A.ToJSON DescribeTable where toJSON = A.genericToJSON $ dropOpt 1 -- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery DescribeTable where type ServiceConfiguration DescribeTable = DdbConfiguration signQuery = ddbSignQuery "DescribeTable" newtype DescribeTableResult = DescribeTableResult { dtStatus :: TableDescription } deriving (Show, A.FromJSON) -- ResponseConsumer can't be derived instance ResponseConsumer r DescribeTableResult where type ResponseMetadata DescribeTableResult = DdbResponse responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse DescribeTableResult where type MemoryResponse DescribeTableResult = TableDescription loadToMemory = return . dtStatus instance Transaction DescribeTable DescribeTableResult data UpdateTable = UpdateTable { updateTableName :: T.Text , updateProvisionedThroughput :: ProvisionedThroughput , updateGlobalSecondaryIndexUpdates :: [GlobalSecondaryIndexUpdate] } deriving (Show, Generic) instance A.ToJSON UpdateTable where toJSON a = A.object $ "TableName" .= updateTableName a : "ProvisionedThroughput" .= updateProvisionedThroughput a : case updateGlobalSecondaryIndexUpdates a of [] -> [] l -> [ "GlobalSecondaryIndexUpdates" .= l ] -- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery UpdateTable where type ServiceConfiguration UpdateTable = DdbConfiguration signQuery = ddbSignQuery "UpdateTable" newtype UpdateTableResult = UpdateTableResult { uStatus :: TableDescription } deriving (Show, A.FromJSON) -- ResponseConsumer can't be derived instance ResponseConsumer r UpdateTableResult where type ResponseMetadata UpdateTableResult = DdbResponse responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse UpdateTableResult where type MemoryResponse UpdateTableResult = TableDescription loadToMemory = return . uStatus instance Transaction UpdateTable UpdateTableResult data DeleteTable = DeleteTable { deleteTableName :: T.Text } deriving (Show, Generic) instance A.ToJSON DeleteTable where toJSON = A.genericToJSON $ dropOpt 6 -- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery DeleteTable where type ServiceConfiguration DeleteTable = DdbConfiguration signQuery = ddbSignQuery "DeleteTable" newtype DeleteTableResult = DeleteTableResult { dStatus :: TableDescription } deriving (Show, A.FromJSON) -- ResponseConsumer can't be derived instance ResponseConsumer r DeleteTableResult where type ResponseMetadata DeleteTableResult = DdbResponse responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse DeleteTableResult where type MemoryResponse DeleteTableResult = TableDescription loadToMemory = return . dStatus instance Transaction DeleteTable DeleteTableResult -- | TODO: currently this does not support restarting a cutoff query because of size. data ListTables = ListTables deriving (Show) instance A.ToJSON ListTables where toJSON _ = A.object [] -- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery ListTables where type ServiceConfiguration ListTables = DdbConfiguration signQuery = ddbSignQuery "ListTables" newtype ListTablesResult = ListTablesResult { tableNames :: [T.Text] } deriving (Show, Generic) instance A.FromJSON ListTablesResult where parseJSON = A.genericParseJSON capitalizeOpt instance ResponseConsumer r ListTablesResult where type ResponseMetadata ListTablesResult = DdbResponse responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse ListTablesResult where type MemoryResponse ListTablesResult = [T.Text] loadToMemory = return . tableNames instance Transaction ListTables ListTablesResult aws-0.13.0/Aws/DynamoDb/Commands/Query.hs0000644000000000000000000001216112615132266016211 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Aws.DynamoDb.Commands.Query -- Copyright : Soostone Inc -- License : BSD3 -- -- Maintainer : Ozgun Ataman -- Stability : experimental -- -- Implementation of Amazon DynamoDb Query command. -- -- See: @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_Query.html@ ---------------------------------------------------------------------------- module Aws.DynamoDb.Commands.Query ( Query (..) , Slice (..) , query , QueryResponse (..) ) where ------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson import Data.Default import Data.Maybe import qualified Data.Text as T import Data.Typeable import qualified Data.Vector as V ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- | 'Slice' is the primary constraint in a 'Query' command, per AWS -- requirements. -- -- All 'Query' commands must specify a hash attribute via 'DEq' and -- optionally provide a secondary range attribute. data Slice = Slice { sliceHash :: Attribute -- ^ Hash value of the primary key or index being used , sliceCond :: Maybe Condition -- ^ An optional condition specified on the range component, if -- present, of the primary key or index being used. } deriving (Eq,Show,Read,Ord,Typeable) -- | A Query command that uses primary keys for an expedient scan. data Query = Query { qTableName :: T.Text -- ^ Required. , qKeyConditions :: Slice -- ^ Required. Hash or hash-range main condition. , qFilter :: Conditions -- ^ Whether to filter results before returning to client , qStartKey :: Maybe [Attribute] -- ^ Exclusive start key to resume a previous query. , qLimit :: Maybe Int -- ^ Whether to limit result set size , qForwardScan :: Bool -- ^ Set to False for descending results , qSelect :: QuerySelect -- ^ What to return from 'Query' , qRetCons :: ReturnConsumption , qIndex :: Maybe T.Text -- ^ Whether to use a secondary/global index , qConsistent :: Bool } deriving (Eq,Show,Read,Ord,Typeable) ------------------------------------------------------------------------------- instance ToJSON Query where toJSON Query{..} = object $ catMaybes [ (("ExclusiveStartKey" .= ) . attributesJson) <$> qStartKey , ("Limit" .= ) <$> qLimit , ("IndexName" .= ) <$> qIndex ] ++ conditionsJson "QueryFilter" qFilter ++ querySelectJson qSelect ++ [ "ScanIndexForward" .= qForwardScan , "TableName".= qTableName , "KeyConditions" .= sliceJson qKeyConditions , "ReturnConsumedCapacity" .= qRetCons , "ConsistentRead" .= qConsistent ] ------------------------------------------------------------------------------- -- | Construct a minimal 'Query' request. query :: T.Text -- ^ Table name -> Slice -- ^ Primary key slice for query -> Query query tn sl = Query tn sl def Nothing Nothing True def def Nothing False -- | Response to a 'Query' query. data QueryResponse = QueryResponse { qrItems :: V.Vector Item , qrLastKey :: Maybe [Attribute] , qrCount :: Int , qrScanned :: Int , qrConsumed :: Maybe ConsumedCapacity } deriving (Eq,Show,Read,Ord) instance FromJSON QueryResponse where parseJSON (Object v) = QueryResponse <$> v .:? "Items" .!= V.empty <*> ((do o <- v .: "LastEvaluatedKey" Just <$> parseAttributeJson o) <|> pure Nothing) <*> v .: "Count" <*> v .: "ScannedCount" <*> v .:? "ConsumedCapacity" parseJSON _ = fail "QueryResponse must be an object." instance Transaction Query QueryResponse instance SignQuery Query where type ServiceConfiguration Query = DdbConfiguration signQuery gi = ddbSignQuery "Query" gi instance ResponseConsumer r QueryResponse where type ResponseMetadata QueryResponse = DdbResponse responseConsumer _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse QueryResponse where type MemoryResponse QueryResponse = QueryResponse loadToMemory = return instance ListResponse QueryResponse Item where listResponse = V.toList . qrItems instance IteratedTransaction Query QueryResponse where nextIteratedRequest request response = case qrLastKey response of Nothing -> Nothing key -> Just request { qStartKey = key } sliceJson :: Slice -> Value sliceJson Slice{..} = object (map conditionJson cs) where cs = maybe [] return sliceCond ++ [hashCond] hashCond = Condition (attrName sliceHash) (DEq (attrVal sliceHash)) aws-0.13.0/Aws/DynamoDb/Commands/GetItem.hs0000644000000000000000000000553512615132266016451 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Aws.DynamoDb.Commands.GetItem -- Copyright : Soostone Inc -- License : BSD3 -- -- Maintainer : Ozgun Ataman -- Stability : experimental -- -- ---------------------------------------------------------------------------- module Aws.DynamoDb.Commands.GetItem where ------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson import Data.Default import qualified Data.Text as T ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core ------------------------------------------------------------------------------- -- | A GetItem query that fetches a specific object from DDB. -- -- See: @http://docs.aws.amazon.com/amazondynamodb/latest/developerguide/API_GetItem.html@ data GetItem = GetItem { giTableName :: T.Text , giKey :: PrimaryKey , giAttrs :: Maybe [T.Text] -- ^ Attributes to get. 'Nothing' grabs everything. , giConsistent :: Bool -- ^ Whether to issue a consistent read. , giRetCons :: ReturnConsumption -- ^ Whether to return consumption stats. } deriving (Eq,Show,Read,Ord) ------------------------------------------------------------------------------- -- | Construct a minimal 'GetItem' request. getItem :: T.Text -- ^ Table name -> PrimaryKey -- ^ Primary key -> GetItem getItem tn k = GetItem tn k Nothing False def -- | Response to a 'GetItem' query. data GetItemResponse = GetItemResponse { girItem :: Maybe Item , girConsumed :: Maybe ConsumedCapacity } deriving (Eq,Show,Read,Ord) instance Transaction GetItem GetItemResponse instance ToJSON GetItem where toJSON GetItem{..} = object $ maybe [] (return . ("AttributesToGet" .=)) giAttrs ++ [ "TableName" .= giTableName , "Key" .= giKey , "ConsistentRead" .= giConsistent , "ReturnConsumedCapacity" .= giRetCons ] instance SignQuery GetItem where type ServiceConfiguration GetItem = DdbConfiguration signQuery gi = ddbSignQuery "GetItem" gi instance FromJSON GetItemResponse where parseJSON (Object v) = GetItemResponse <$> v .:? "Item" <*> v .:? "ConsumedCapacity" parseJSON _ = fail "GetItemResponse must be an object." instance ResponseConsumer r GetItemResponse where type ResponseMetadata GetItemResponse = DdbResponse responseConsumer _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse GetItemResponse where type MemoryResponse GetItemResponse = GetItemResponse loadToMemory = return aws-0.13.0/Aws/DynamoDb/Commands/UpdateItem.hs0000644000000000000000000001163212615132266017147 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Aws.DynamoDb.Commands.UpdateItem -- Copyright : Soostone Inc -- License : BSD3 -- -- Maintainer : Ozgun Ataman -- Stability : experimental -- -- ---------------------------------------------------------------------------- module Aws.DynamoDb.Commands.UpdateItem where ------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson import Data.Default import qualified Data.Text as T ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core ------------------------------------------------------------------------------- -- | An @UpdateItem@ request. data UpdateItem = UpdateItem { uiTable :: T.Text , uiKey :: PrimaryKey , uiUpdates :: [AttributeUpdate] , uiExpect :: Conditions -- ^ Conditional update - see DynamoDb documentation , uiReturn :: UpdateReturn , uiRetCons :: ReturnConsumption , uiRetMet :: ReturnItemCollectionMetrics } deriving (Eq,Show,Read,Ord) ------------------------------------------------------------------------------- -- | Construct a minimal 'UpdateItem' request. updateItem :: T.Text -- ^ Table name -> PrimaryKey -- ^ Primary key for item -> [AttributeUpdate] -- ^ Updates for this item -> UpdateItem updateItem tn key ups = UpdateItem tn key ups def def def def type AttributeUpdates = [AttributeUpdate] data AttributeUpdate = AttributeUpdate { auAttr :: Attribute -- ^ Attribute key-value , auAction :: UpdateAction -- ^ Type of update operation. } deriving (Eq,Show,Read,Ord) instance DynSize AttributeUpdate where dynSize (AttributeUpdate a _) = dynSize a ------------------------------------------------------------------------------- -- | Shorthand for the 'AttributeUpdate' constructor. Defaults to PUT -- for the update action. au :: Attribute -> AttributeUpdate au a = AttributeUpdate a def instance ToJSON AttributeUpdates where toJSON = object . map mk where mk AttributeUpdate { auAction = UDelete, auAttr = auAttr } = (attrName auAttr) .= object ["Action" .= UDelete] mk AttributeUpdate { .. } = (attrName auAttr) .= object ["Value" .= (attrVal auAttr), "Action" .= auAction] ------------------------------------------------------------------------------- -- | Type of attribute update to perform. -- -- See AWS docs at: -- -- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_UpdateItem.html@ data UpdateAction = UPut -- ^ Simpley write, overwriting any previous value | UAdd -- ^ Numerical add or add to set. | UDelete -- ^ Empty value: remove; Set value: Subtract from set. deriving (Eq,Show,Read,Ord) instance ToJSON UpdateAction where toJSON UPut = String "PUT" toJSON UAdd = String "ADD" toJSON UDelete = String "DELETE" instance Default UpdateAction where def = UPut instance ToJSON UpdateItem where toJSON UpdateItem{..} = object $ expectsJson uiExpect ++ [ "TableName" .= uiTable , "Key" .= uiKey , "AttributeUpdates" .= uiUpdates , "ReturnValues" .= uiReturn , "ReturnConsumedCapacity" .= uiRetCons , "ReturnItemCollectionMetrics" .= uiRetMet ] data UpdateItemResponse = UpdateItemResponse { uirAttrs :: Maybe Item -- ^ Old attributes, if requested , uirConsumed :: Maybe ConsumedCapacity -- ^ Amount of capacity consumed } deriving (Eq,Show,Read,Ord) instance Transaction UpdateItem UpdateItemResponse instance SignQuery UpdateItem where type ServiceConfiguration UpdateItem = DdbConfiguration signQuery gi = ddbSignQuery "UpdateItem" gi instance FromJSON UpdateItemResponse where parseJSON (Object v) = UpdateItemResponse <$> v .:? "Attributes" <*> v .:? "ConsumedCapacity" parseJSON _ = fail "UpdateItemResponse expected a JSON object" instance ResponseConsumer r UpdateItemResponse where type ResponseMetadata UpdateItemResponse = DdbResponse responseConsumer _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse UpdateItemResponse where type MemoryResponse UpdateItemResponse = UpdateItemResponse loadToMemory = return aws-0.13.0/Aws/Ec2/0000755000000000000000000000000012615132266011722 5ustar0000000000000000aws-0.13.0/Aws/Ec2/InstanceMetadata.hs0000644000000000000000000000276312615132266015473 0ustar0000000000000000module Aws.Ec2.InstanceMetadata where import Control.Applicative import Control.Exception import Control.Monad.Trans.Resource (throwM) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as B8 import Data.ByteString.Lazy.UTF8 as BU import Data.Typeable import qualified Network.HTTP.Conduit as HTTP data InstanceMetadataException = MetadataNotFound String deriving (Show, Typeable) instance Exception InstanceMetadataException getInstanceMetadata :: HTTP.Manager -> String -> String -> IO L.ByteString getInstanceMetadata mgr p x = do req <- HTTP.parseUrl ("http://169.254.169.254/" ++ p ++ '/' : x) HTTP.responseBody <$> HTTP.httpLbs req mgr getInstanceMetadataListing :: HTTP.Manager -> String -> IO [String] getInstanceMetadataListing mgr p = map BU.toString . B8.split '\n' <$> getInstanceMetadata mgr p "" getInstanceMetadataFirst :: HTTP.Manager -> String -> IO L.ByteString getInstanceMetadataFirst mgr p = do listing <- getInstanceMetadataListing mgr p case listing of [] -> throwM (MetadataNotFound p) (x:_) -> getInstanceMetadata mgr p x getInstanceMetadataOrFirst :: HTTP.Manager -> String -> Maybe String -> IO L.ByteString getInstanceMetadataOrFirst mgr p (Just x) = getInstanceMetadata mgr p x getInstanceMetadataOrFirst mgr p Nothing = getInstanceMetadataFirst mgr p aws-0.13.0/Aws/Ses/0000755000000000000000000000000012615132266012043 5ustar0000000000000000aws-0.13.0/Aws/Ses/Commands.hs0000644000000000000000000000234512615132266014144 0ustar0000000000000000module Aws.Ses.Commands ( module Aws.Ses.Commands.SendRawEmail , module Aws.Ses.Commands.ListIdentities , module Aws.Ses.Commands.VerifyEmailIdentity , module Aws.Ses.Commands.VerifyDomainIdentity , module Aws.Ses.Commands.VerifyDomainDkim , module Aws.Ses.Commands.DeleteIdentity , module Aws.Ses.Commands.GetIdentityDkimAttributes , module Aws.Ses.Commands.GetIdentityNotificationAttributes , module Aws.Ses.Commands.GetIdentityVerificationAttributes , module Aws.Ses.Commands.SetIdentityNotificationTopic , module Aws.Ses.Commands.SetIdentityDkimEnabled , module Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled ) where import Aws.Ses.Commands.SendRawEmail import Aws.Ses.Commands.ListIdentities import Aws.Ses.Commands.VerifyEmailIdentity import Aws.Ses.Commands.VerifyDomainIdentity import Aws.Ses.Commands.VerifyDomainDkim import Aws.Ses.Commands.DeleteIdentity import Aws.Ses.Commands.GetIdentityDkimAttributes import Aws.Ses.Commands.GetIdentityNotificationAttributes import Aws.Ses.Commands.GetIdentityVerificationAttributes import Aws.Ses.Commands.SetIdentityNotificationTopic import Aws.Ses.Commands.SetIdentityDkimEnabled import Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled aws-0.13.0/Aws/Ses/Core.hs0000644000000000000000000001507212615132266013274 0ustar0000000000000000module Aws.Ses.Core ( SesError(..) , SesMetadata(..) , SesConfiguration(..) , sesEuWest1 , sesUsEast , sesUsEast1 , sesUsWest2 , sesHttpsGet , sesHttpsPost , sesSignQuery , sesResponseConsumer , RawMessage(..) , Destination(..) , EmailAddress , Sender(..) , sesAsQuery ) where import Aws.Core import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C import Control.Monad (mplus) import Control.Monad.Trans.Resource (throwM) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 ({-IsString-}) import Data.IORef import Data.Maybe import Data.Monoid import Data.Text (Text) import qualified Data.Text.Encoding as TE import Data.Typeable import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import Text.XML.Cursor (($/), ($//)) import qualified Text.XML.Cursor as Cu data SesError = SesError { sesStatusCode :: HTTP.Status , sesErrorCode :: Text , sesErrorMessage :: Text } deriving (Show, Typeable) instance C.Exception SesError data SesMetadata = SesMetadata { requestId :: Maybe Text } deriving (Show, Typeable) instance Loggable SesMetadata where toLogText (SesMetadata rid) = "SES: request ID=" `mappend` fromMaybe "" rid instance Monoid SesMetadata where mempty = SesMetadata Nothing SesMetadata r1 `mappend` SesMetadata r2 = SesMetadata (r1 `mplus` r2) data SesConfiguration qt = SesConfiguration { sesiHttpMethod :: Method , sesiHost :: B.ByteString } deriving (Show) -- HTTP is not supported right now, always use HTTPS instance DefaultServiceConfiguration (SesConfiguration NormalQuery) where defServiceConfig = sesHttpsPost sesUsEast1 instance DefaultServiceConfiguration (SesConfiguration UriOnlyQuery) where defServiceConfig = sesHttpsGet sesUsEast1 sesEuWest1 :: B.ByteString sesEuWest1 = "email.eu-west-1.amazonaws.com" sesUsEast :: B.ByteString sesUsEast = sesUsEast1 sesUsEast1 :: B.ByteString sesUsEast1 = "email.us-east-1.amazonaws.com" sesUsWest2 :: B.ByteString sesUsWest2 = "email.us-west-2.amazonaws.com" sesHttpsGet :: B.ByteString -> SesConfiguration qt sesHttpsGet endpoint = SesConfiguration Get endpoint sesHttpsPost :: B.ByteString -> SesConfiguration NormalQuery sesHttpsPost endpoint = SesConfiguration PostQuery endpoint sesSignQuery :: [(B.ByteString, B.ByteString)] -> SesConfiguration qt -> SignatureData -> SignedQuery sesSignQuery query si sd = SignedQuery { sqMethod = sesiHttpMethod si , sqProtocol = HTTPS , sqHost = sesiHost si , sqPort = defaultPort HTTPS , sqPath = "/" , sqQuery = HTTP.simpleQueryToQuery query' , sqDate = Just $ signatureTime sd , sqAuthorization = Nothing , sqContentType = Nothing , sqContentMd5 = Nothing , sqAmzHeaders = amzHeaders , sqOtherHeaders = [] , sqBody = Nothing , sqStringToSign = stringToSign } where stringToSign = fmtRfc822Time (signatureTime sd) credentials = signatureCredentials sd accessKeyId = accessKeyID credentials amzHeaders = catMaybes [ Just ("X-Amzn-Authorization", authorization) , ("x-amz-security-token",) `fmap` iamToken credentials ] authorization = B.concat [ "AWS3-HTTPS AWSAccessKeyId=" , accessKeyId , ", Algorithm=HmacSHA256, Signature=" , signature credentials HmacSHA256 stringToSign ] query' = ("AWSAccessKeyId", accessKeyId) : query sesResponseConsumer :: (Cu.Cursor -> Response SesMetadata a) -> IORef SesMetadata -> HTTPResponseConsumer a sesResponseConsumer inner metadataRef resp = xmlCursorConsumer parse metadataRef resp where parse cursor = do let requestId' = listToMaybe $ cursor $// elContent "RequestID" tellMetadata $ SesMetadata requestId' case cursor $/ Cu.laxElement "Error" of [] -> inner cursor (err:_) -> fromError err fromError cursor = do errCode <- force "Missing Error Code" $ cursor $// elContent "Code" errMessage <- force "Missing Error Message" $ cursor $// elContent "Message" throwM $ SesError (HTTP.responseStatus resp) errCode errMessage class SesAsQuery a where -- | Write a data type as a list of query parameters. sesAsQuery :: a -> [(B.ByteString, B.ByteString)] instance SesAsQuery a => SesAsQuery (Maybe a) where sesAsQuery = maybe [] sesAsQuery -- | A raw e-mail. data RawMessage = RawMessage { rawMessageData :: B.ByteString } deriving (Eq, Ord, Show, Typeable) instance SesAsQuery RawMessage where sesAsQuery = (:[]) . (,) "RawMessage.Data" . B64.encode . rawMessageData -- | The destinations of an e-mail. data Destination = Destination { destinationBccAddresses :: [EmailAddress] , destinationCcAddresses :: [EmailAddress] , destinationToAddresses :: [EmailAddress] } deriving (Eq, Ord, Show, Typeable) instance SesAsQuery Destination where sesAsQuery (Destination bcc cc to) = concat [ go (s "Bcc") bcc , go (s "Cc") cc , go (s "To") to ] where go kind = zipWith f (map Blaze8.fromShow [one..]) where txt = kind `mappend` s "Addresses.member." f n v = ( Blaze.toByteString (txt `mappend` n) , TE.encodeUtf8 v ) s = Blaze.fromByteString one = 1 :: Int instance Monoid Destination where mempty = Destination [] [] [] mappend (Destination a1 a2 a3) (Destination b1 b2 b3) = Destination (a1 ++ b1) (a2 ++ b2) (a3 ++ b3) -- | An e-mail address. type EmailAddress = Text -- | The sender's e-mail address. data Sender = Sender { senderAddress :: EmailAddress } deriving (Eq, Ord, Show, Typeable) instance SesAsQuery Sender where sesAsQuery = (:[]) . (,) "Source" . TE.encodeUtf8 . senderAddress aws-0.13.0/Aws/Ses/Commands/0000755000000000000000000000000012615132266013604 5ustar0000000000000000aws-0.13.0/Aws/Ses/Commands/DeleteIdentity.hs0000644000000000000000000000241712615132266017060 0ustar0000000000000000module Aws.Ses.Commands.DeleteIdentity ( DeleteIdentity(..) , DeleteIdentityResponse(..) ) where import Data.Text (Text) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Aws.Core import Aws.Ses.Core -- | Delete an email address or domain data DeleteIdentity = DeleteIdentity Text deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery DeleteIdentity where type ServiceConfiguration DeleteIdentity = SesConfiguration signQuery (DeleteIdentity identity) = sesSignQuery [ ("Action", "DeleteIdentity") , ("Identity", T.encodeUtf8 identity) ] -- | The response sent back by Amazon SES after a -- 'DeleteIdentity' command. data DeleteIdentityResponse = DeleteIdentityResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer DeleteIdentity DeleteIdentityResponse where type ResponseMetadata DeleteIdentityResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \_ -> return DeleteIdentityResponse instance Transaction DeleteIdentity DeleteIdentityResponse where instance AsMemoryResponse DeleteIdentityResponse where type MemoryResponse DeleteIdentityResponse = DeleteIdentityResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/VerifyDomainIdentity.hs0000644000000000000000000000304412615132266020247 0ustar0000000000000000module Aws.Ses.Commands.VerifyDomainIdentity ( VerifyDomainIdentity(..) , VerifyDomainIdentityResponse(..) ) where import Data.Text (Text) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Aws.Core import Aws.Ses.Core import Text.XML.Cursor (($//)) -- | Verify ownership of a domain. data VerifyDomainIdentity = VerifyDomainIdentity Text deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery VerifyDomainIdentity where type ServiceConfiguration VerifyDomainIdentity = SesConfiguration signQuery (VerifyDomainIdentity domain) = sesSignQuery [ ("Action", "VerifyDomainIdentity") , ("Domain", T.encodeUtf8 domain) ] -- | The response sent back by Amazon SES after a -- 'VerifyDomainIdentity' command. data VerifyDomainIdentityResponse = VerifyDomainIdentityResponse Text deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer VerifyDomainIdentity VerifyDomainIdentityResponse where type ResponseMetadata VerifyDomainIdentityResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \cursor -> do token <- force "Verification token not found" $ cursor $// elContent "VerificationToken" return (VerifyDomainIdentityResponse token) instance Transaction VerifyDomainIdentity VerifyDomainIdentityResponse where instance AsMemoryResponse VerifyDomainIdentityResponse where type MemoryResponse VerifyDomainIdentityResponse = VerifyDomainIdentityResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/VerifyEmailIdentity.hs0000644000000000000000000000257412615132266020076 0ustar0000000000000000module Aws.Ses.Commands.VerifyEmailIdentity ( VerifyEmailIdentity(..) , VerifyEmailIdentityResponse(..) ) where import Data.Text (Text) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Aws.Core import Aws.Ses.Core -- | List email addresses and/or domains data VerifyEmailIdentity = VerifyEmailIdentity Text deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery VerifyEmailIdentity where type ServiceConfiguration VerifyEmailIdentity = SesConfiguration signQuery (VerifyEmailIdentity address) = sesSignQuery [ ("Action", "VerifyEmailIdentity") , ("EmailAddress", T.encodeUtf8 address) ] -- | The response sent back by Amazon SES after a -- 'VerifyEmailIdentity' command. data VerifyEmailIdentityResponse = VerifyEmailIdentityResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer VerifyEmailIdentity VerifyEmailIdentityResponse where type ResponseMetadata VerifyEmailIdentityResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \_ -> return VerifyEmailIdentityResponse instance Transaction VerifyEmailIdentity VerifyEmailIdentityResponse where instance AsMemoryResponse VerifyEmailIdentityResponse where type MemoryResponse VerifyEmailIdentityResponse = VerifyEmailIdentityResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs0000644000000000000000000000533612615132266023012 0ustar0000000000000000module Aws.Ses.Commands.GetIdentityVerificationAttributes ( GetIdentityVerificationAttributes(..) , GetIdentityVerificationAttributesResponse(..) , IdentityVerificationAttributes(..) ) where import Data.Text (Text) import qualified Data.ByteString.Char8 as BS import Data.Maybe (listToMaybe) import Control.Applicative ((<$>)) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Text.XML.Cursor (($//), ($/), (&|), laxElement) import Aws.Core import Aws.Ses.Core -- | Get verification status for a list of email addresses and/or domains data GetIdentityVerificationAttributes = GetIdentityVerificationAttributes [Text] deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery GetIdentityVerificationAttributes where type ServiceConfiguration GetIdentityVerificationAttributes = SesConfiguration signQuery (GetIdentityVerificationAttributes identities) = sesSignQuery $ ("Action", "GetIdentityVerificationAttributes") : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities) where enumMember (n :: Int) = BS.append "Identities.member." (BS.pack $ show n) data IdentityVerificationAttributes = IdentityVerificationAttributes { ivIdentity :: Text , ivVerificationStatus :: Text , ivVerificationToken :: Maybe Text } deriving (Eq, Ord, Show, Typeable) -- | The response sent back by Amazon SES after a -- 'GetIdentityVerificationAttributes' command. data GetIdentityVerificationAttributesResponse = GetIdentityVerificationAttributesResponse [IdentityVerificationAttributes] deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer GetIdentityVerificationAttributes GetIdentityVerificationAttributesResponse where type ResponseMetadata GetIdentityVerificationAttributesResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \cursor -> do let buildAttr e = do ivIdentity <- force "Missing Key" $ e $/ elContent "key" ivVerificationStatus <- force "Missing Verification Status" $ e $// elContent "VerificationStatus" let ivVerificationToken = listToMaybe $ e $// elContent "VerificationToken" return IdentityVerificationAttributes {..} attributes <- sequence $ cursor $// laxElement "entry" &| buildAttr return $ GetIdentityVerificationAttributesResponse attributes instance Transaction GetIdentityVerificationAttributes GetIdentityVerificationAttributesResponse where instance AsMemoryResponse GetIdentityVerificationAttributesResponse where type MemoryResponse GetIdentityVerificationAttributesResponse = GetIdentityVerificationAttributesResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/GetIdentityDkimAttributes.hs0000644000000000000000000000554012615132266021251 0ustar0000000000000000module Aws.Ses.Commands.GetIdentityDkimAttributes ( GetIdentityDkimAttributes(..) , GetIdentityDkimAttributesResponse(..) , IdentityDkimAttributes(..) ) where import Control.Applicative ((<$>)) import qualified Data.ByteString.Char8 as BS import Data.Text (Text) import Data.Text as T (toCaseFold) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Text.XML.Cursor (laxElement, ($/), ($//), (&/), (&|)) import Aws.Core import Aws.Ses.Core -- | Get notification settings for the given identities. data GetIdentityDkimAttributes = GetIdentityDkimAttributes [Text] deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery GetIdentityDkimAttributes where type ServiceConfiguration GetIdentityDkimAttributes = SesConfiguration signQuery (GetIdentityDkimAttributes identities) = sesSignQuery $ ("Action", "GetIdentityDkimAttributes") : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities) where enumMember (n :: Int) = BS.append "Identities.member." (BS.pack $ show n) data IdentityDkimAttributes = IdentityDkimAttributes { idIdentity :: Text , idDkimEnabled :: Bool , idDkimTokens :: [Text] , idDkimVerirficationStatus :: Text } deriving (Eq, Ord, Show, Typeable) -- | The response sent back by Amazon SES after a -- 'GetIdentityDkimAttributes' command. data GetIdentityDkimAttributesResponse = GetIdentityDkimAttributesResponse [IdentityDkimAttributes] deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer GetIdentityDkimAttributes GetIdentityDkimAttributesResponse where type ResponseMetadata GetIdentityDkimAttributesResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \cursor -> do let buildAttr e = do idIdentity <- force "Missing Key" $ e $/ elContent "key" enabled <- force "Missing DkimEnabled" $ e $// elContent "DkimEnabled" idDkimVerirficationStatus <- force "Missing status" $ e $// elContent "DkimVerificationStatus" let idDkimEnabled = T.toCaseFold enabled == T.toCaseFold "true" idDkimTokens = e $// laxElement "DkimTokens" &/ elContent "member" return IdentityDkimAttributes{..} attributes <- sequence $ cursor $// laxElement "entry" &| buildAttr return $ GetIdentityDkimAttributesResponse attributes instance Transaction GetIdentityDkimAttributes GetIdentityDkimAttributesResponse where instance AsMemoryResponse GetIdentityDkimAttributesResponse where type MemoryResponse GetIdentityDkimAttributesResponse = GetIdentityDkimAttributesResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/ListIdentities.hs0000644000000000000000000000421712615132266017101 0ustar0000000000000000module Aws.Ses.Commands.ListIdentities ( ListIdentities(..) , ListIdentitiesResponse(..) , IdentityType(..) ) where import Data.Text (Text) import qualified Data.ByteString.Char8 as BS import Data.Maybe (catMaybes) import Control.Applicative ((<$>)) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Text.XML.Cursor (($//), (&/), laxElement) import Aws.Core import Aws.Ses.Core -- | List email addresses and/or domains data ListIdentities = ListIdentities { liIdentityType :: Maybe IdentityType , liMaxItems :: Maybe Int -- valid range is 1..100 , liNextToken :: Maybe Text } deriving (Eq, Ord, Show, Typeable) data IdentityType = EmailAddress | Domain deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery ListIdentities where type ServiceConfiguration ListIdentities = SesConfiguration signQuery ListIdentities {..} = let it = case liIdentityType of Just EmailAddress -> Just "EmailAddress" Just Domain -> Just "Domain" Nothing -> Nothing in sesSignQuery $ ("Action", "ListIdentities") : catMaybes [ ("IdentityType",) <$> it , ("MaxItems",) . BS.pack . show <$> liMaxItems , ("NextToken",) . T.encodeUtf8 <$> liNextToken ] -- | The response sent back by Amazon SES after a -- 'ListIdentities' command. data ListIdentitiesResponse = ListIdentitiesResponse [Text] deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer ListIdentities ListIdentitiesResponse where type ResponseMetadata ListIdentitiesResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \cursor -> do let ids = cursor $// laxElement "Identities" &/ elContent "member" return $ ListIdentitiesResponse ids instance Transaction ListIdentities ListIdentitiesResponse where instance AsMemoryResponse ListIdentitiesResponse where type MemoryResponse ListIdentitiesResponse = ListIdentitiesResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/SendRawEmail.hs0000644000000000000000000000362512615132266016461 0ustar0000000000000000module Aws.Ses.Commands.SendRawEmail ( SendRawEmail(..) , SendRawEmailResponse(..) ) where import Data.Text (Text) import Data.Typeable import Control.Applicative ((<$>)) import qualified Data.ByteString.Char8 as BS import Text.XML.Cursor (($//)) import qualified Data.Text.Encoding as T import Aws.Core import Aws.Ses.Core -- | Send a raw e-mail message. data SendRawEmail = SendRawEmail { srmDestinations :: [EmailAddress] , srmRawMessage :: RawMessage , srmSource :: Maybe Sender } deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery SendRawEmail where type ServiceConfiguration SendRawEmail = SesConfiguration signQuery SendRawEmail {..} = sesSignQuery $ ("Action", "SendRawEmail") : concat [ destinations , sesAsQuery srmRawMessage , sesAsQuery srmSource ] where destinations = zip (enumMember <$> ([1..] :: [Int])) (T.encodeUtf8 <$> srmDestinations) enumMember = BS.append "Destinations.member." . BS.pack . show -- | The response sent back by Amazon SES after a -- 'SendRawEmail' command. data SendRawEmailResponse = SendRawEmailResponse { srmrMessageId :: Text } deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer SendRawEmail SendRawEmailResponse where type ResponseMetadata SendRawEmailResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \cursor -> do messageId <- force "MessageId not found" $ cursor $// elContent "MessageId" return (SendRawEmailResponse messageId) instance Transaction SendRawEmail SendRawEmailResponse where instance AsMemoryResponse SendRawEmailResponse where type MemoryResponse SendRawEmailResponse = SendRawEmailResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/SetIdentityNotificationTopic.hs0000644000000000000000000000474012615132266021760 0ustar0000000000000000module Aws.Ses.Commands.SetIdentityNotificationTopic ( SetIdentityNotificationTopic(..) , SetIdentityNotificationTopicResponse(..) , NotificationType(..) ) where import Data.Text (Text) import Control.Applicative ((<$>)) import Data.Maybe (maybeToList) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Aws.Core import Aws.Ses.Core data NotificationType = Bounce | Complaint deriving (Eq, Ord, Show, Typeable) -- | Change or remove the Amazon SNS notification topic to which notification -- of the given type are published. data SetIdentityNotificationTopic = SetIdentityNotificationTopic { sntIdentity :: Text -- ^ The identity for which the SNS topic will be changed. , sntNotificationType :: NotificationType -- ^ The type of notifications that will be published to the topic. , sntSnsTopic :: Maybe Text -- ^ @Just@ the ARN of the SNS topic or @Nothing@ to unset the topic. } deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery SetIdentityNotificationTopic where type ServiceConfiguration SetIdentityNotificationTopic = SesConfiguration signQuery SetIdentityNotificationTopic{..} = let notificationType = case sntNotificationType of Bounce -> "Bounce" Complaint -> "Complaint" snsTopic = ("SnsTopic",) . T.encodeUtf8 <$> sntSnsTopic in sesSignQuery $ [ ("Action", "SetIdentityNotificationTopic") , ("Identity", T.encodeUtf8 sntIdentity) , ("NotificationType", notificationType) ] ++ maybeToList snsTopic -- | The response sent back by SES after the 'SetIdentityNotificationTopic' -- command. data SetIdentityNotificationTopicResponse = SetIdentityNotificationTopicResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer SetIdentityNotificationTopic SetIdentityNotificationTopicResponse where type ResponseMetadata SetIdentityNotificationTopicResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \_ -> return SetIdentityNotificationTopicResponse instance Transaction SetIdentityNotificationTopic SetIdentityNotificationTopicResponse instance AsMemoryResponse SetIdentityNotificationTopicResponse where type MemoryResponse SetIdentityNotificationTopicResponse = SetIdentityNotificationTopicResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs0000644000000000000000000000571312615132266023015 0ustar0000000000000000module Aws.Ses.Commands.GetIdentityNotificationAttributes ( GetIdentityNotificationAttributes(..) , GetIdentityNotificationAttributesResponse(..) , IdentityNotificationAttributes(..) ) where import Data.Text (Text) import qualified Data.ByteString.Char8 as BS import Control.Applicative ((<$>)) import Data.Text.Encoding as T (encodeUtf8) import Data.Text as T (toCaseFold) import Data.Typeable import Text.XML.Cursor (($//), ($/), (&|), laxElement) import Aws.Core import Aws.Ses.Core -- | Get notification settings for the given identities. data GetIdentityNotificationAttributes = GetIdentityNotificationAttributes [Text] deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery GetIdentityNotificationAttributes where type ServiceConfiguration GetIdentityNotificationAttributes = SesConfiguration signQuery (GetIdentityNotificationAttributes identities) = sesSignQuery $ ("Action", "GetIdentityNotificationAttributes") : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities) where enumMember (n :: Int) = BS.append "Identities.member." (BS.pack $ show n) data IdentityNotificationAttributes = IdentityNotificationAttributes { inIdentity :: Text , inBounceTopic :: Maybe Text , inComplaintTopic :: Maybe Text , inForwardingEnabled :: Bool } deriving (Eq, Ord, Show, Typeable) -- | The response sent back by Amazon SES after a -- 'GetIdentityNotificationAttributes' command. data GetIdentityNotificationAttributesResponse = GetIdentityNotificationAttributesResponse [IdentityNotificationAttributes] deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer GetIdentityNotificationAttributes GetIdentityNotificationAttributesResponse where type ResponseMetadata GetIdentityNotificationAttributesResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \cursor -> do let buildAttr e = do inIdentity <- force "Missing Key" $ e $/ elContent "key" fwdText <- force "Missing ForwardingEnabled" $ e $// elContent "ForwardingEnabled" let inBounceTopic = headOrNothing (e $// elContent "BounceTopic") inComplaintTopic = headOrNothing (e $// elContent "ComplaintTopic") inForwardingEnabled = T.toCaseFold fwdText == T.toCaseFold "true" return IdentityNotificationAttributes{..} attributes <- sequence $ cursor $// laxElement "entry" &| buildAttr return $ GetIdentityNotificationAttributesResponse attributes where headOrNothing (x:_) = Just x headOrNothing _ = Nothing instance Transaction GetIdentityNotificationAttributes GetIdentityNotificationAttributesResponse where instance AsMemoryResponse GetIdentityNotificationAttributesResponse where type MemoryResponse GetIdentityNotificationAttributesResponse = GetIdentityNotificationAttributesResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/SetIdentityDkimEnabled.hs0000644000000000000000000000320212615132266020462 0ustar0000000000000000module Aws.Ses.Commands.SetIdentityDkimEnabled ( SetIdentityDkimEnabled(..) , SetIdentityDkimEnabledResponse(..) ) where import Aws.Core import Aws.Ses.Core import Data.Text (Text) import Data.Text.Encoding as T import Data.Typeable -- | Change whether bounces and complaints for the given identity will be -- DKIM signed. data SetIdentityDkimEnabled = SetIdentityDkimEnabled { sdDkimEnabled :: Bool , sdIdentity :: Text } deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery SetIdentityDkimEnabled where type ServiceConfiguration SetIdentityDkimEnabled = SesConfiguration signQuery SetIdentityDkimEnabled{..} = sesSignQuery [ ("Action", "SetIdentityDkimEnabled") , ("Identity", T.encodeUtf8 sdIdentity) , ("DkimEnabled", awsBool sdDkimEnabled) ] -- | The response sent back by SES after the 'SetIdentityDkimEnabled' command. data SetIdentityDkimEnabledResponse = SetIdentityDkimEnabledResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer SetIdentityDkimEnabled SetIdentityDkimEnabledResponse where type ResponseMetadata SetIdentityDkimEnabledResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \_ -> return SetIdentityDkimEnabledResponse instance Transaction SetIdentityDkimEnabled SetIdentityDkimEnabledResponse instance AsMemoryResponse SetIdentityDkimEnabledResponse where type MemoryResponse SetIdentityDkimEnabledResponse = SetIdentityDkimEnabledResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs0000644000000000000000000000366012615132266023315 0ustar0000000000000000module Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled ( SetIdentityFeedbackForwardingEnabled(..) , SetIdentityFeedbackForwardingEnabledResponse(..) ) where import Data.Text (Text) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Aws.Core import Aws.Ses.Core -- | Change whether bounces and complaints for the given identity will be -- forwarded as email. data SetIdentityFeedbackForwardingEnabled = SetIdentityFeedbackForwardingEnabled { sffForwardingEnabled :: Bool , sffIdentity :: Text } deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery SetIdentityFeedbackForwardingEnabled where type ServiceConfiguration SetIdentityFeedbackForwardingEnabled = SesConfiguration signQuery SetIdentityFeedbackForwardingEnabled{..} = sesSignQuery [ ("Action", "SetIdentityFeedbackForwardingEnabled") , ("Identity", T.encodeUtf8 sffIdentity) , ("ForwardingEnabled", awsBool sffForwardingEnabled) ] -- | The response sent back by SES after the -- 'SetIdentityFeedbackForwardingEnabled' command. data SetIdentityFeedbackForwardingEnabledResponse = SetIdentityFeedbackForwardingEnabledResponse deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse where type ResponseMetadata SetIdentityFeedbackForwardingEnabledResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \_ -> return SetIdentityFeedbackForwardingEnabledResponse instance Transaction SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse instance AsMemoryResponse SetIdentityFeedbackForwardingEnabledResponse where type MemoryResponse SetIdentityFeedbackForwardingEnabledResponse = SetIdentityFeedbackForwardingEnabledResponse loadToMemory = return aws-0.13.0/Aws/Ses/Commands/VerifyDomainDkim.hs0000644000000000000000000000271712615132266017350 0ustar0000000000000000module Aws.Ses.Commands.VerifyDomainDkim ( VerifyDomainDkim(..) , VerifyDomainDkimResponse(..) ) where import Data.Text (Text) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Aws.Core import Aws.Ses.Core import Text.XML.Cursor (($//), laxElement, (&/)) -- | Verify ownership of a domain. data VerifyDomainDkim = VerifyDomainDkim Text deriving (Eq, Ord, Show, Typeable) -- | ServiceConfiguration: 'SesConfiguration' instance SignQuery VerifyDomainDkim where type ServiceConfiguration VerifyDomainDkim = SesConfiguration signQuery (VerifyDomainDkim domain) = sesSignQuery [ ("Action", "VerifyDomainDkim") , ("Domain", T.encodeUtf8 domain) ] -- | The response sent back by Amazon SES after a 'VerifyDomainDkim' command. data VerifyDomainDkimResponse = VerifyDomainDkimResponse [Text] deriving (Eq, Ord, Show, Typeable) instance ResponseConsumer VerifyDomainDkim VerifyDomainDkimResponse where type ResponseMetadata VerifyDomainDkimResponse = SesMetadata responseConsumer _ = sesResponseConsumer $ \cursor -> do let tokens = cursor $// laxElement "DkimTokens" &/ elContent "member" return (VerifyDomainDkimResponse tokens) instance Transaction VerifyDomainDkim VerifyDomainDkimResponse where instance AsMemoryResponse VerifyDomainDkimResponse where type MemoryResponse VerifyDomainDkimResponse = VerifyDomainDkimResponse loadToMemory = return aws-0.13.0/Aws/SimpleDb/0000755000000000000000000000000012615132266013010 5ustar0000000000000000aws-0.13.0/Aws/SimpleDb/Commands.hs0000644000000000000000000000041612615132266015106 0ustar0000000000000000module Aws.SimpleDb.Commands ( module Aws.SimpleDb.Commands.Attributes , module Aws.SimpleDb.Commands.Domain , module Aws.SimpleDb.Commands.Select ) where import Aws.SimpleDb.Commands.Attributes import Aws.SimpleDb.Commands.Domain import Aws.SimpleDb.Commands.Select aws-0.13.0/Aws/SimpleDb/Core.hs0000644000000000000000000002236112615132266014240 0ustar0000000000000000module Aws.SimpleDb.Core where import Aws.Core import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C import Control.Monad import Control.Monad.Trans.Resource (MonadThrow, throwM) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64 import Data.IORef import Data.List import Data.Maybe import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import Text.XML.Cursor (($|), ($/), ($//), (&|)) import qualified Text.XML.Cursor as Cu type ErrorCode = String data SdbError = SdbError { sdbStatusCode :: HTTP.Status , sdbErrorCode :: ErrorCode , sdbErrorMessage :: String } deriving (Show, Typeable) instance C.Exception SdbError data SdbMetadata = SdbMetadata { requestId :: Maybe T.Text , boxUsage :: Maybe T.Text } deriving (Show, Typeable) instance Loggable SdbMetadata where toLogText (SdbMetadata rid bu) = "SimpleDB: request ID=" `mappend` fromMaybe "" rid `mappend` ", box usage=" `mappend` fromMaybe "" bu instance Monoid SdbMetadata where mempty = SdbMetadata Nothing Nothing SdbMetadata r1 b1 `mappend` SdbMetadata r2 b2 = SdbMetadata (r1 `mplus` r2) (b1 `mplus` b2) data SdbConfiguration qt = SdbConfiguration { sdbiProtocol :: Protocol , sdbiHttpMethod :: Method , sdbiHost :: B.ByteString , sdbiPort :: Int } deriving (Show) instance DefaultServiceConfiguration (SdbConfiguration NormalQuery) where defServiceConfig = sdbHttpsPost sdbUsEast debugServiceConfig = sdbHttpPost sdbUsEast instance DefaultServiceConfiguration (SdbConfiguration UriOnlyQuery) where defServiceConfig = sdbHttpsGet sdbUsEast debugServiceConfig = sdbHttpGet sdbUsEast sdbUsEast :: B.ByteString sdbUsEast = "sdb.amazonaws.com" sdbUsWest :: B.ByteString sdbUsWest = "sdb.us-west-1.amazonaws.com" sdbEuWest :: B.ByteString sdbEuWest = "sdb.eu-west-1.amazonaws.com" sdbApSoutheast :: B.ByteString sdbApSoutheast = "sdb.ap-southeast-1.amazonaws.com" sdbApNortheast :: B.ByteString sdbApNortheast = "sdb.ap-northeast-1.amazonaws.com" sdbHttpGet :: B.ByteString -> SdbConfiguration qt sdbHttpGet endpoint = SdbConfiguration HTTP Get endpoint (defaultPort HTTP) sdbHttpPost :: B.ByteString -> SdbConfiguration NormalQuery sdbHttpPost endpoint = SdbConfiguration HTTP PostQuery endpoint (defaultPort HTTP) sdbHttpsGet :: B.ByteString -> SdbConfiguration qt sdbHttpsGet endpoint = SdbConfiguration HTTPS Get endpoint (defaultPort HTTPS) sdbHttpsPost :: B.ByteString -> SdbConfiguration NormalQuery sdbHttpsPost endpoint = SdbConfiguration HTTPS PostQuery endpoint (defaultPort HTTPS) sdbSignQuery :: [(B.ByteString, B.ByteString)] -> SdbConfiguration qt -> SignatureData -> SignedQuery sdbSignQuery q si sd = SignedQuery { sqMethod = method , sqProtocol = sdbiProtocol si , sqHost = host , sqPort = sdbiPort si , sqPath = path , sqQuery = sq , sqDate = Just $ signatureTime sd , sqAuthorization = Nothing , sqContentType = Nothing , sqContentMd5 = Nothing , sqAmzHeaders = [] , sqOtherHeaders = [] , sqBody = Nothing , sqStringToSign = stringToSign } where ah = HmacSHA256 q' = HTTP.toQuery . sort $ q ++ ("Version", "2009-04-15") : queryAuth ti = signatureTimeInfo sd cr = signatureCredentials sd queryAuth = [case ti of AbsoluteTimestamp time -> ("Timestamp", fmtAmzTime time) AbsoluteExpires time -> ("Expires", fmtAmzTime time) , ("AWSAccessKeyId", accessKeyID cr) , ("SignatureMethod", amzHash ah) , ("SignatureVersion", "2")] ++ maybe [] (\tok -> [("SecurityToken", tok)]) (iamToken cr) sq = ("Signature", Just sig) : q' method = sdbiHttpMethod si host = sdbiHost si path = "/" sig = signature cr ah stringToSign stringToSign = Blaze.toByteString . mconcat $ intersperse (Blaze8.fromChar '\n') [Blaze.copyByteString $ httpMethod method , Blaze.copyByteString $ host , Blaze.copyByteString $ path , HTTP.renderQueryBuilder False q'] sdbResponseConsumer :: (Cu.Cursor -> Response SdbMetadata a) -> IORef SdbMetadata -> HTTPResponseConsumer a sdbResponseConsumer inner metadataRef resp = xmlCursorConsumer parse metadataRef resp where parse cursor = do let requestId' = listToMaybe $ cursor $// elContent "RequestID" let boxUsage' = listToMaybe $ cursor $// elContent "BoxUsage" tellMetadata $ SdbMetadata requestId' boxUsage' case cursor $// Cu.laxElement "Error" of [] -> inner cursor (err:_) -> fromError err fromError cursor = do errCode <- force "Missing Error Code" $ cursor $// elCont "Code" errMessage <- force "Missing Error Message" $ cursor $// elCont "Message" throwM $ SdbError (HTTP.responseStatus resp) errCode errMessage class SdbFromResponse a where sdbFromResponse :: Cu.Cursor -> Response SdbMetadata a sdbCheckResponseType :: MonadThrow m => a -> T.Text -> Cu.Cursor -> m a sdbCheckResponseType a n c = do _ <- force ("Expected response type " ++ T.unpack n) (Cu.laxElement n c) return a decodeBase64 :: MonadThrow m => Cu.Cursor -> m T.Text decodeBase64 cursor = let encoded = T.concat $ cursor $/ Cu.content encoding = listToMaybe $ cursor $| Cu.laxAttribute "encoding" &| T.toCaseFold in case encoding of Nothing -> return encoded Just "base64" -> case Base64.decode . T.encodeUtf8 $ encoded of Left msg -> throwM $ XmlException ("Invalid Base64 data: " ++ msg) Right x -> return $ T.decodeUtf8 x Just actual -> throwM $ XmlException ("Unrecognized encoding " ++ T.unpack actual) data Attribute a = ForAttribute { attributeName :: T.Text, attributeData :: a } deriving (Show) readAttribute :: MonadThrow m => Cu.Cursor -> m (Attribute T.Text) readAttribute cursor = do name <- forceM "Missing Name" $ cursor $/ Cu.laxElement "Name" &| decodeBase64 value <- forceM "Missing Value" $ cursor $/ Cu.laxElement "Value" &| decodeBase64 return $ ForAttribute name value data SetAttribute = SetAttribute { setAttribute :: T.Text, isReplaceAttribute :: Bool } deriving (Show) attributeQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Attribute a -> [(B.ByteString, B.ByteString)] attributeQuery f (ForAttribute name x) = ("Name", T.encodeUtf8 name) : f x addAttribute :: T.Text -> T.Text -> Attribute SetAttribute addAttribute name value = ForAttribute name (SetAttribute value False) replaceAttribute :: T.Text -> T.Text -> Attribute SetAttribute replaceAttribute name value = ForAttribute name (SetAttribute value True) setAttributeQuery :: SetAttribute -> [(B.ByteString, B.ByteString)] setAttributeQuery (SetAttribute value replace) = ("Value", T.encodeUtf8 value) : [("Replace", awsTrue) | replace] data DeleteAttribute = DeleteAttribute | ValuedDeleteAttribute { deleteAttributeValue :: T.Text } deriving (Show) deleteAttributeQuery :: DeleteAttribute -> [(B.ByteString, B.ByteString)] deleteAttributeQuery DeleteAttribute = [] deleteAttributeQuery (ValuedDeleteAttribute value) = [("Value", T.encodeUtf8 value)] data ExpectedAttribute = ExpectedValue { expectedAttributeValue :: T.Text } | ExpectedExists { expectedAttributeExists :: Bool } deriving (Show) expectedValue :: T.Text -> T.Text -> Attribute ExpectedAttribute expectedValue name value = ForAttribute name (ExpectedValue value) expectedExists :: T.Text -> Bool -> Attribute ExpectedAttribute expectedExists name exists = ForAttribute name (ExpectedExists exists) expectedAttributeQuery :: ExpectedAttribute -> [(B.ByteString, B.ByteString)] expectedAttributeQuery (ExpectedValue value) = [("Value", T.encodeUtf8 value)] expectedAttributeQuery (ExpectedExists exists) = [("Exists", awsBool exists)] data Item a = Item { itemName :: T.Text, itemData :: a } deriving (Show) readItem :: MonadThrow m => Cu.Cursor -> m (Item [Attribute T.Text]) readItem cursor = do name <- force "Missing Name" <=< sequence $ cursor $/ Cu.laxElement "Name" &| decodeBase64 attributes <- sequence $ cursor $/ Cu.laxElement "Attribute" &| readAttribute return $ Item name attributes itemQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Item a -> [(B.ByteString, B.ByteString)] itemQuery f (Item name x) = ("ItemName", T.encodeUtf8 name) : f x aws-0.13.0/Aws/SimpleDb/Commands/0000755000000000000000000000000012615132266014551 5ustar0000000000000000aws-0.13.0/Aws/SimpleDb/Commands/Attributes.hs0000644000000000000000000002032312615132266017233 0ustar0000000000000000module Aws.SimpleDb.Commands.Attributes where import Aws.Core import Aws.SimpleDb.Core import Control.Applicative import Control.Monad import Data.Maybe import Text.XML.Cursor (($//), (&|)) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Text.XML.Cursor as Cu data GetAttributes = GetAttributes { gaItemName :: T.Text , gaAttributeName :: Maybe T.Text , gaConsistentRead :: Bool , gaDomainName :: T.Text } deriving (Show) data GetAttributesResponse = GetAttributesResponse { garAttributes :: [Attribute T.Text] } deriving (Show) getAttributes :: T.Text -> T.Text -> GetAttributes getAttributes item domain = GetAttributes { gaItemName = item, gaAttributeName = Nothing, gaConsistentRead = False, gaDomainName = domain } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery GetAttributes where type ServiceConfiguration GetAttributes = SdbConfiguration signQuery GetAttributes{..} = sdbSignQuery $ [("Action", "GetAttributes"), ("ItemName", T.encodeUtf8 gaItemName), ("DomainName", T.encodeUtf8 gaDomainName)] ++ maybeToList (("AttributeName",) <$> T.encodeUtf8 <$> gaAttributeName) ++ (guard gaConsistentRead >> [("ConsistentRead", awsTrue)]) instance ResponseConsumer r GetAttributesResponse where type ResponseMetadata GetAttributesResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "GetAttributesResponse" cursor attributes <- sequence $ cursor $// Cu.laxElement "Attribute" &| readAttribute return $ GetAttributesResponse attributes instance Transaction GetAttributes GetAttributesResponse instance AsMemoryResponse GetAttributesResponse where type MemoryResponse GetAttributesResponse = GetAttributesResponse loadToMemory = return data PutAttributes = PutAttributes { paItemName :: T.Text , paAttributes :: [Attribute SetAttribute] , paExpected :: [Attribute ExpectedAttribute] , paDomainName :: T.Text } deriving (Show) data PutAttributesResponse = PutAttributesResponse deriving (Show) putAttributes :: T.Text -> [Attribute SetAttribute] -> T.Text -> PutAttributes putAttributes item attributes domain = PutAttributes { paItemName = item , paAttributes = attributes , paExpected = [] , paDomainName = domain } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery PutAttributes where type ServiceConfiguration PutAttributes = SdbConfiguration signQuery PutAttributes{..} = sdbSignQuery $ [("Action", "PutAttributes"), ("ItemName", T.encodeUtf8 paItemName), ("DomainName", T.encodeUtf8 paDomainName)] ++ queryList (attributeQuery setAttributeQuery) "Attribute" paAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" paExpected instance ResponseConsumer r PutAttributesResponse where type ResponseMetadata PutAttributesResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse" instance Transaction PutAttributes PutAttributesResponse instance AsMemoryResponse PutAttributesResponse where type MemoryResponse PutAttributesResponse = PutAttributesResponse loadToMemory = return data DeleteAttributes = DeleteAttributes { daItemName :: T.Text , daAttributes :: [Attribute DeleteAttribute] , daExpected :: [Attribute ExpectedAttribute] , daDomainName :: T.Text } deriving (Show) data DeleteAttributesResponse = DeleteAttributesResponse deriving (Show) deleteAttributes :: T.Text -> [Attribute DeleteAttribute] -> T.Text -> DeleteAttributes deleteAttributes item attributes domain = DeleteAttributes { daItemName = item , daAttributes = attributes , daExpected = [] , daDomainName = domain } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery DeleteAttributes where type ServiceConfiguration DeleteAttributes = SdbConfiguration signQuery DeleteAttributes{..} = sdbSignQuery $ [("Action", "DeleteAttributes"), ("ItemName", T.encodeUtf8 daItemName), ("DomainName", T.encodeUtf8 daDomainName)] ++ queryList (attributeQuery deleteAttributeQuery) "Attribute" daAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" daExpected instance ResponseConsumer r DeleteAttributesResponse where type ResponseMetadata DeleteAttributesResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse" instance Transaction DeleteAttributes DeleteAttributesResponse instance AsMemoryResponse DeleteAttributesResponse where type MemoryResponse DeleteAttributesResponse = DeleteAttributesResponse loadToMemory = return data BatchPutAttributes = BatchPutAttributes { bpaItems :: [Item [Attribute SetAttribute]] , bpaDomainName :: T.Text } deriving (Show) data BatchPutAttributesResponse = BatchPutAttributesResponse deriving (Show) batchPutAttributes :: [Item [Attribute SetAttribute]] -> T.Text -> BatchPutAttributes batchPutAttributes items domain = BatchPutAttributes { bpaItems = items, bpaDomainName = domain } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery BatchPutAttributes where type ServiceConfiguration BatchPutAttributes = SdbConfiguration signQuery BatchPutAttributes{..} = sdbSignQuery $ [("Action", "BatchPutAttributes") , ("DomainName", T.encodeUtf8 bpaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery setAttributeQuery) "Attribute") "Item" bpaItems instance ResponseConsumer r BatchPutAttributesResponse where type ResponseMetadata BatchPutAttributesResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse" instance Transaction BatchPutAttributes BatchPutAttributesResponse instance AsMemoryResponse BatchPutAttributesResponse where type MemoryResponse BatchPutAttributesResponse = BatchPutAttributesResponse loadToMemory = return data BatchDeleteAttributes = BatchDeleteAttributes { bdaItems :: [Item [Attribute DeleteAttribute]] , bdaDomainName :: T.Text } deriving (Show) data BatchDeleteAttributesResponse = BatchDeleteAttributesResponse deriving (Show) batchDeleteAttributes :: [Item [Attribute DeleteAttribute]] -> T.Text -> BatchDeleteAttributes batchDeleteAttributes items domain = BatchDeleteAttributes { bdaItems = items, bdaDomainName = domain } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery BatchDeleteAttributes where type ServiceConfiguration BatchDeleteAttributes = SdbConfiguration signQuery BatchDeleteAttributes{..} = sdbSignQuery $ [("Action", "BatchDeleteAttributes") , ("DomainName", T.encodeUtf8 bdaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery deleteAttributeQuery) "Attribute") "Item" bdaItems instance ResponseConsumer r BatchDeleteAttributesResponse where type ResponseMetadata BatchDeleteAttributesResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse" instance Transaction BatchDeleteAttributes BatchDeleteAttributesResponse instance AsMemoryResponse BatchDeleteAttributesResponse where type MemoryResponse BatchDeleteAttributesResponse = BatchDeleteAttributesResponse loadToMemory = returnaws-0.13.0/Aws/SimpleDb/Commands/Select.hs0000644000000000000000000000435012615132266016326 0ustar0000000000000000module Aws.SimpleDb.Commands.Select where import Aws.Core import Aws.SimpleDb.Core import Control.Applicative import Control.Monad import Data.Maybe import Text.XML.Cursor (($//), (&|)) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Text.XML.Cursor as Cu data Select = Select { sSelectExpression :: T.Text , sConsistentRead :: Bool , sNextToken :: Maybe T.Text } deriving (Show) data SelectResponse = SelectResponse { srItems :: [Item [Attribute T.Text]] , srNextToken :: Maybe T.Text } deriving (Show) select :: T.Text -> Select select expr = Select { sSelectExpression = expr, sConsistentRead = False, sNextToken = Nothing } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery Select where type ServiceConfiguration Select = SdbConfiguration signQuery Select{..} = sdbSignQuery . catMaybes $ [ Just ("Action", "Select") , Just ("SelectExpression", T.encodeUtf8 sSelectExpression) , ("ConsistentRead", awsTrue) <$ guard sConsistentRead , (("NextToken",) . T.encodeUtf8) <$> sNextToken ] instance ResponseConsumer r SelectResponse where type ResponseMetadata SelectResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "SelectResponse" cursor items <- sequence $ cursor $// Cu.laxElement "Item" &| readItem let nextToken = listToMaybe $ cursor $// elContent "NextToken" return $ SelectResponse items nextToken instance Transaction Select SelectResponse instance AsMemoryResponse SelectResponse where type MemoryResponse SelectResponse = SelectResponse loadToMemory = return instance ListResponse SelectResponse (Item [Attribute T.Text]) where listResponse = srItems instance IteratedTransaction Select SelectResponse where nextIteratedRequest req SelectResponse{srNextToken=nt} = req{sNextToken=nt} <$ nt -- combineIteratedResponse (SelectResponse s1 _) (SelectResponse s2 nt2) = SelectResponse (s1 ++ s2) nt2 aws-0.13.0/Aws/SimpleDb/Commands/Domain.hs0000644000000000000000000001474412615132266016326 0ustar0000000000000000module Aws.SimpleDb.Commands.Domain where import Aws.Core import Aws.SimpleDb.Core import Control.Applicative import Data.Maybe import Data.Time import Data.Time.Clock.POSIX import Text.XML.Cursor (($//), (&|)) import qualified Data.Text as T import qualified Data.Text.Encoding as T data CreateDomain = CreateDomain { cdDomainName :: T.Text } deriving (Show) data CreateDomainResponse = CreateDomainResponse deriving (Show) createDomain :: T.Text -> CreateDomain createDomain name = CreateDomain { cdDomainName = name } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery CreateDomain where type ServiceConfiguration CreateDomain = SdbConfiguration signQuery CreateDomain{..} = sdbSignQuery [("Action", "CreateDomain"), ("DomainName", T.encodeUtf8 cdDomainName)] instance ResponseConsumer r CreateDomainResponse where type ResponseMetadata CreateDomainResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse" instance Transaction CreateDomain CreateDomainResponse instance AsMemoryResponse CreateDomainResponse where type MemoryResponse CreateDomainResponse = CreateDomainResponse loadToMemory = return data DeleteDomain = DeleteDomain { ddDomainName :: T.Text } deriving (Show) data DeleteDomainResponse = DeleteDomainResponse deriving (Show) deleteDomain :: T.Text -> DeleteDomain deleteDomain name = DeleteDomain { ddDomainName = name } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery DeleteDomain where type ServiceConfiguration DeleteDomain = SdbConfiguration signQuery DeleteDomain{..} = sdbSignQuery [("Action", "DeleteDomain"), ("DomainName", T.encodeUtf8 ddDomainName)] instance ResponseConsumer r DeleteDomainResponse where type ResponseMetadata DeleteDomainResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse" instance Transaction DeleteDomain DeleteDomainResponse instance AsMemoryResponse DeleteDomainResponse where type MemoryResponse DeleteDomainResponse = DeleteDomainResponse loadToMemory = return data DomainMetadata = DomainMetadata { dmDomainName :: T.Text } deriving (Show) data DomainMetadataResponse = DomainMetadataResponse { dmrTimestamp :: UTCTime , dmrItemCount :: Integer , dmrAttributeValueCount :: Integer , dmrAttributeNameCount :: Integer , dmrItemNamesSizeBytes :: Integer , dmrAttributeValuesSizeBytes :: Integer , dmrAttributeNamesSizeBytes :: Integer } deriving (Show) domainMetadata :: T.Text -> DomainMetadata domainMetadata name = DomainMetadata { dmDomainName = name } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery DomainMetadata where type ServiceConfiguration DomainMetadata = SdbConfiguration signQuery DomainMetadata{..} = sdbSignQuery [("Action", "DomainMetadata"), ("DomainName", T.encodeUtf8 dmDomainName)] instance ResponseConsumer r DomainMetadataResponse where type ResponseMetadata DomainMetadataResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "DomainMetadataResponse" cursor dmrTimestamp <- forceM "Timestamp expected" $ cursor $// elCont "Timestamp" &| (fmap posixSecondsToUTCTime . readInt) dmrItemCount <- forceM "ItemCount expected" $ cursor $// elCont "ItemCount" &| readInt dmrAttributeValueCount <- forceM "AttributeValueCount expected" $ cursor $// elCont "AttributeValueCount" &| readInt dmrAttributeNameCount <- forceM "AttributeNameCount expected" $ cursor $// elCont "AttributeNameCount" &| readInt dmrItemNamesSizeBytes <- forceM "ItemNamesSizeBytes expected" $ cursor $// elCont "ItemNamesSizeBytes" &| readInt dmrAttributeValuesSizeBytes <- forceM "AttributeValuesSizeBytes expected" $ cursor $// elCont "AttributeValuesSizeBytes" &| readInt dmrAttributeNamesSizeBytes <- forceM "AttributeNamesSizeBytes expected" $ cursor $// elCont "AttributeNamesSizeBytes" &| readInt return DomainMetadataResponse{..} instance Transaction DomainMetadata DomainMetadataResponse instance AsMemoryResponse DomainMetadataResponse where type MemoryResponse DomainMetadataResponse = DomainMetadataResponse loadToMemory = return data ListDomains = ListDomains { ldMaxNumberOfDomains :: Maybe Int , ldNextToken :: Maybe T.Text } deriving (Show) data ListDomainsResponse = ListDomainsResponse { ldrDomainNames :: [T.Text] , ldrNextToken :: Maybe T.Text } deriving (Show) listDomains :: ListDomains listDomains = ListDomains { ldMaxNumberOfDomains = Nothing, ldNextToken = Nothing } -- | ServiceConfiguration: 'SdbConfiguration' instance SignQuery ListDomains where type ServiceConfiguration ListDomains = SdbConfiguration signQuery ListDomains{..} = sdbSignQuery $ catMaybes [ Just ("Action", "ListDomains") , ("MaxNumberOfDomains",) . T.encodeUtf8 . T.pack . show <$> ldMaxNumberOfDomains , ("NextToken",) . T.encodeUtf8 <$> ldNextToken ] instance ResponseConsumer r ListDomainsResponse where type ResponseMetadata ListDomainsResponse = SdbMetadata responseConsumer _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "ListDomainsResponse" cursor let names = cursor $// elContent "DomainName" let nextToken = listToMaybe $ cursor $// elContent "NextToken" return $ ListDomainsResponse names nextToken instance Transaction ListDomains ListDomainsResponse instance AsMemoryResponse ListDomainsResponse where type MemoryResponse ListDomainsResponse = ListDomainsResponse loadToMemory = return instance ListResponse ListDomainsResponse T.Text where listResponse = ldrDomainNames instance IteratedTransaction ListDomains ListDomainsResponse where nextIteratedRequest req ListDomainsResponse{ldrNextToken=nt} = req{ldNextToken=nt} <$ nt --combineIteratedResponse (ListDomainsResponse dn1 _) (ListDomainsResponse dn2 nt2) = ListDomainsResponse (dn1 ++ dn2) nt2 aws-0.13.0/tests/0000755000000000000000000000000012615132266011721 5ustar0000000000000000aws-0.13.0/tests/Utils.hs0000644000000000000000000001374112615132266013363 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} -- | -- Module: Utils -- Copyright: Copyright © 2014 AlephCloud Systems, Inc. -- License: BSD3 -- Maintainer: Lars Kuhtz -- Stability: experimental -- -- Utils for Tests for Haskell AWS bindints -- module Utils ( -- * Parameters testDataPrefix -- * General Utils , sshow , mustFail , tryT , retryT , retryT_ , testData , evalTestT , evalTestTM , eitherTOnceTest0 , eitherTOnceTest1 , eitherTOnceTest2 -- * Generic Tests , test_jsonRoundtrip , prop_jsonRoundtrip ) where import Control.Applicative import Control.Concurrent (threadDelay) import qualified Control.Exception.Lifted as LE import Control.Error hiding (syncIO) import Control.Monad import Control.Monad.Identity import Control.Monad.IO.Class import Control.Monad.Base import Control.Monad.Trans.Control import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode) import Data.Dynamic (Dynamic) import Data.Monoid import Data.Proxy import Data.String import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Typeable import Test.QuickCheck.Property import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.QuickCheck import System.Exit (ExitCode) import System.IO (stderr) import Data.Time.Clock.POSIX (getPOSIXTime) -- -------------------------------------------------------------------------- -- -- Static Test parameters -- -- | This prefix is used for the IDs and names of all entities that are -- created in the AWS account. -- testDataPrefix :: IsString a => MonadBase IO m => m a testDataPrefix = do t <- liftBase $ getPOSIXTime let t' :: Int t' = floor (t * 1000) return . fromString $ "__TEST_AWSHASKELLBINDINGS__" ++ show t' -- -------------------------------------------------------------------------- -- -- General Utils -- | Catches all exceptions except for asynchronous exceptions found in base. -- tryT :: MonadBaseControl IO m => m a -> ExceptT T.Text m a tryT = fmapLT (T.pack . show) . syncIO -- | Lifted Version of 'syncIO' form "Control.Error.Util". -- syncIO :: MonadBaseControl IO m => m a -> ExceptT LE.SomeException m a syncIO a = ExceptT $ LE.catches (Right <$> a) [ LE.Handler $ \e -> LE.throw (e :: LE.ArithException) , LE.Handler $ \e -> LE.throw (e :: LE.ArrayException) , LE.Handler $ \e -> LE.throw (e :: LE.AssertionFailed) , LE.Handler $ \e -> LE.throw (e :: LE.AsyncException) , LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnMVar) , LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnSTM) , LE.Handler $ \e -> LE.throw (e :: LE.Deadlock) , LE.Handler $ \e -> LE.throw (e :: Dynamic) , LE.Handler $ \e -> LE.throw (e :: LE.ErrorCall) , LE.Handler $ \e -> LE.throw (e :: ExitCode) , LE.Handler $ \e -> LE.throw (e :: LE.NestedAtomically) , LE.Handler $ \e -> LE.throw (e :: LE.NoMethodError) , LE.Handler $ \e -> LE.throw (e :: LE.NonTermination) , LE.Handler $ \e -> LE.throw (e :: LE.PatternMatchFail) , LE.Handler $ \e -> LE.throw (e :: LE.RecConError) , LE.Handler $ \e -> LE.throw (e :: LE.RecSelError) , LE.Handler $ \e -> LE.throw (e :: LE.RecUpdError) , LE.Handler $ return . Left ] testData :: (IsString a, Monoid a, MonadBaseControl IO m) => a -> m a testData a = fmap (<> a) testDataPrefix retryT :: (Functor m, MonadIO m) => Int -> ExceptT T.Text m a -> ExceptT T.Text m a retryT n f = snd <$> retryT_ n f retryT_ :: (Functor m, MonadIO m) => Int -> ExceptT T.Text m a -> ExceptT T.Text m (Int, a) retryT_ n f = go 1 where go x | x >= n = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) ((x,) <$> f) | otherwise = ((x,) <$> f) `catchE` \e -> do liftIO $ T.hPutStrLn stderr $ "Retrying after error: " <> e liftIO $ threadDelay (1000000 * min 60 (2^(x-1))) go (succ x) sshow :: (Show a, IsString b) => a -> b sshow = fromString . show mustFail :: Monad m => ExceptT e m a -> ExceptT T.Text m () mustFail = ExceptT . exceptT (const . return $ Right ()) (const . return $ Left "operation succeeded when a failure was expected") evalTestTM :: Functor f => String -- ^ test name -> f (ExceptT T.Text IO a) -- ^ test -> f (PropertyM IO Bool) evalTestTM name = fmap $ (liftIO . runExceptT) >=> \r -> case r of Left e -> fail $ "failed to run test \"" <> name <> "\": " <> show e Right _ -> return True evalTestT :: String -- ^ test name -> ExceptT T.Text IO a -- ^ test -> PropertyM IO Bool evalTestT name = runIdentity . evalTestTM name . Identity eitherTOnceTest0 :: String -- ^ test name -> ExceptT T.Text IO a -- ^ test -> TestTree eitherTOnceTest0 name test = testProperty name . once . monadicIO $ evalTestT name test eitherTOnceTest1 :: (Arbitrary a, Show a) => String -- ^ test name -> (a -> ExceptT T.Text IO b) -> TestTree eitherTOnceTest1 name test = testProperty name . once $ monadicIO . evalTestTM name test eitherTOnceTest2 :: (Arbitrary a, Show a, Arbitrary b, Show b) => String -- ^ test name -> (a -> b -> ExceptT T.Text IO c) -> TestTree eitherTOnceTest2 name test = testProperty name . once $ \a b -> monadicIO $ (evalTestTM name $ uncurry test) (a, b) -- -------------------------------------------------------------------------- -- -- Generic Tests test_jsonRoundtrip :: forall a . (Eq a, Show a, FromJSON a, ToJSON a, Typeable a, Arbitrary a) => Proxy a -> TestTree test_jsonRoundtrip proxy = testProperty msg (prop_jsonRoundtrip :: a -> Property) where msg = "JSON roundtrip for " <> show typ #if MIN_VERSION_base(4,7,0) typ = typeRep proxy #else typ = typeOf (undefined :: a) #endif prop_jsonRoundtrip :: forall a . (Eq a, Show a, FromJSON a, ToJSON a) => a -> Property prop_jsonRoundtrip a = either (const $ property False) (\(b :: [a]) -> [a] === b) $ eitherDecode $ encode [a] aws-0.13.0/tests/Sqs/0000755000000000000000000000000012615132266012467 5ustar0000000000000000aws-0.13.0/tests/Sqs/Main.hs0000644000000000000000000003147212615132266013716 0ustar0000000000000000-- ------------------------------------------------------ -- -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module: Main -- Copyright: Copyright © 2014 AlephCloud Systems, Inc. -- License: BSD3 -- Maintainer: Lars Kuhtz -- Stability: experimental -- -- Tests for Haskell SQS bindings -- module Main ( main ) where import Aws import Aws.Core import qualified Aws.Sqs as SQS import Control.Arrow (second) import Control.Error import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import Data.IORef import qualified Data.List as L import Data.Monoid import qualified Data.Text as T import qualified Network.HTTP.Client as HTTP import Test.Tasty import Test.QuickCheck.Instances () import System.Environment import System.Exit import Utils -- -------------------------------------------------------------------------- -- -- Main main :: IO () main = do args <- getArgs runMain args $ map (second tail . span (/= '=')) args where runMain :: [String] -> [(String,String)] -> IO () runMain args _argsMap | any (`elem` helpArgs) args = defaultMain tests | "--run-with-aws-credentials" `elem` args = withArgs (tastyArgs args) . defaultMain $ tests | otherwise = putStrLn help >> exitFailure helpArgs = ["--help", "-h"] mainArgs = [ "--run-with-aws-credentials" ] tastyArgs args = flip filter args $ \x -> not $ any (`L.isPrefixOf` x) mainArgs help :: String help = L.intercalate "\n" [ "" , "NOTE" , "" , "This test suite accesses the AWS account that is associated with" , "the default credentials from the credential file ~/.aws-keys." , "" , "By running the tests in this test-suite costs for usage of AWS" , "services may incur." , "" , "In order to actually excute the tests in this test-suite you must" , "provide the command line options:" , "" , " --run-with-aws-credentials" , "" , "When running this test-suite through cabal you may use the following" , "command:" , "" , " cabal test --test-option=--run-with-aws-credentials sqs-tests" , "" ] tests :: TestTree tests = withQueueTest defaultQueueName $ \getQueueParams -> testGroup "SQS Tests" [ test_queue , test_message getQueueParams , test_core getQueueParams ] -- -------------------------------------------------------------------------- -- -- Static Test parameters -- -- TODO make these configurable testProtocol :: Protocol testProtocol = HTTP testSqsEndpoint :: SQS.Endpoint testSqsEndpoint = SQS.sqsEndpointUsWest2 defaultQueueName :: T.Text defaultQueueName = "test-queue" -- -------------------------------------------------------------------------- -- -- SQS Utils sqsQueueName :: T.Text -> SQS.QueueName sqsQueueName url = SQS.QueueName (sqsQueueNameText url) (sqsAccountIdText url) sqsQueueNameText :: T.Text -> T.Text sqsQueueNameText url = T.split (== '/') url !! 4 sqsAccountIdText :: T.Text -> T.Text sqsAccountIdText url = T.split (== '/') url !! 3 sqsConfiguration :: SQS.SqsConfiguration qt sqsConfiguration = SQS.SqsConfiguration { SQS.sqsProtocol = testProtocol , SQS.sqsEndpoint = testSqsEndpoint , SQS.sqsPort = 80 , SQS.sqsUseUri = False , SQS.sqsDefaultExpiry = 180 } sqsT :: (Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration) => Configuration -> HTTP.Manager -> r -> ExceptT T.Text IO a sqsT cfg manager req = do Response _ r <- liftIO . runResourceT $ aws cfg sqsConfiguration manager req hoistEither $ fmapL sshow r simpleSqs :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m) => r -> m (MemoryResponse a) simpleSqs command = do c <- baseConfiguration simpleAws c sqsConfiguration command simpleSqsT :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadBaseControl IO m, MonadIO m) => r -> ExceptT T.Text m (MemoryResponse a) simpleSqsT = tryT . simpleSqs withQueueTest :: T.Text -- ^ Queue name -> (IO (T.Text, SQS.QueueName) -> TestTree) -- ^ test tree -> TestTree withQueueTest queueName f = withResource createQueue deleteQueue $ \getQueueUrl -> f $ do url <- getQueueUrl return (url, sqsQueueName url) where createQueue = do SQS.CreateQueueResponse url <- simpleSqs $ SQS.CreateQueue Nothing queueName return url deleteQueue url = void $ simpleSqs (SQS.DeleteQueue (sqsQueueName url)) -- -------------------------------------------------------------------------- -- -- Queue Tests test_queue :: TestTree test_queue = testGroup "Queue Tests" [ eitherTOnceTest1 "CreateListDeleteQueue" prop_createListDeleteQueue ] -- | -- prop_createListDeleteQueue :: T.Text -- ^ queue name -> ExceptT T.Text IO () prop_createListDeleteQueue queueName = do tQueueName <- testData queueName SQS.CreateQueueResponse queueUrl <- simpleSqsT $ SQS.CreateQueue Nothing tQueueName let queue = sqsQueueName queueUrl flip catchE (\e -> deleteQueue queue >> throwE e) $ do retryT 6 $ do SQS.ListQueuesResponse allQueueUrls <- simpleSqsT (SQS.ListQueues Nothing) unless (queueUrl `elem` allQueueUrls) . throwE $ "queue " <> sshow queueUrl <> " not listed" deleteQueue queue where deleteQueue queueUrl = void $ simpleSqsT (SQS.DeleteQueue queueUrl) -- -------------------------------------------------------------------------- -- -- Message Tests test_message :: IO (T.Text, SQS.QueueName) -> TestTree test_message getQueueParams = testGroup "Queue Tests" [ eitherTOnceTest0 "SendReceiveDeleteMessage" $ do (_, queue) <- liftIO getQueueParams prop_sendReceiveDeleteMessage queue , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling" $ do (_, queue) <- liftIO getQueueParams prop_sendReceiveDeleteMessageLongPolling queue , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling1" $ do (_, queue) <- liftIO getQueueParams prop_sendReceiveDeleteMessageLongPolling1 queue ] -- | Simple send and short-polling receive. First sends all messages -- and receives messages thereafter one by one. -- prop_sendReceiveDeleteMessage :: SQS.QueueName -> ExceptT T.Text IO () prop_sendReceiveDeleteMessage queue = do -- a visibility timeout should be used only if either @receiveBatch == 1@ -- or no retry is used so that all received messages are handled. let visTimeout = Just 60 let delay = Just 0 let poll = Nothing -- no consistent receive (any number of messages up to the requested number can be returned) let receiveBatch = 1 let msgNum = 10 let messages = map (\i -> "message" <> sshow i) [1 .. msgNum] -- send messages forM_ messages $ \msg -> void . simpleSqsT $ SQS.SendMessage msg queue [] delay recMsgs <- fmap concat . replicateM msgNum $ do msgs <- retryT 5 $ do r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll case r of SQS.ReceiveMessageResponse [] -> throwE "no message received" SQS.ReceiveMessageResponse t | length t <= receiveBatch -> return t | otherwise -> throwE $ "unexpected number of messages received: " <> sshow (length t) forM_ msgs $ \msg -> retryT 5 $ simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue return (map SQS.mBody msgs) let recv = L.sort recMsgs let sent = L.sort messages unless (sent == recv) $ throwE $ "received messages don't match send messages; sent: " <> sshow sent <> "; got: " <> sshow recv -- | Checks for consistent receive: There is no message delay, so all messages -- are available when the first receive is requested. By enabling long-polling -- (with value 0) we force SQS to do a consistent receive. -- prop_sendReceiveDeleteMessageLongPolling :: SQS.QueueName -> ExceptT T.Text IO () prop_sendReceiveDeleteMessageLongPolling queue = do let delay = Nothing let visTimeout = Just 60 let poll = Just 1 -- consistent receive (maximum available number of requested messages is returned) let receiveBatch = 10 let msgNum = 40 -- this must be a multiple of 'receiveBatch' let messages = map (\i -> "message" <> sshow i) [1 .. msgNum] -- send messages forM_ messages $ \msg -> void . simpleSqsT $ SQS.SendMessage msg queue [] delay recMsgs <- fmap concat . replicateM (msgNum `div` receiveBatch) $ do msgs <- do r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll case r of SQS.ReceiveMessageResponse [] -> throwE "no messages received" SQS.ReceiveMessageResponse t | length t == receiveBatch -> return t | otherwise -> throwE $ "unexpected number of messages received: " <> sshow (length t) forM_ msgs $ \msg -> retryT 5 $ simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue return (map SQS.mBody msgs) let recv = L.sort recMsgs let sent = L.sort messages unless (sent == recv) $ throwE $ "received messages don't match send messages; sent: " <> sshow sent <> "; got: " <> sshow recv -- | Checks that long polling is actually enabled. We add a delay to the messages -- and immediately make a receive request with a polling wait time that is larger -- than the delay. Note that even though polling forces consistent reads, messages -- will become available with some (small) offset. Therefor we request only a single -- message at a time. -- prop_sendReceiveDeleteMessageLongPolling1 :: SQS.QueueName -> ExceptT T.Text IO () prop_sendReceiveDeleteMessageLongPolling1 queue = do let delay = Just 2 let visTimeout = Just 60 let poll = Just 5 -- consistent receive (maximum available number of requested messages is returned) let receiveBatch = 1 let msgNum = 10 -- this must be a multiple of 'receiveBatch' let messages = map (\i -> "message" <> sshow i) [1 :: Int .. msgNum] recMsgs <- fmap concat . forM messages $ \msg -> do void . simpleSqsT $ SQS.SendMessage msg queue [] delay msgs <- do r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll case r of SQS.ReceiveMessageResponse [] -> throwE "no messages received" SQS.ReceiveMessageResponse t | length t == receiveBatch -> return t | otherwise -> throwE $ "unexpected number of messages received: " <> sshow (length t) forM_ msgs $ \m -> retryT 5 $ simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle m) queue return (map SQS.mBody msgs) let recv = L.sort recMsgs let sent = L.sort messages unless (sent == recv) $ throwE $ "received messages don't match send messages; sent: " <> sshow sent <> "; got: " <> sshow recv -- -------------------------------------------------------------------------- -- -- Test core functionality test_core :: IO (T.Text, SQS.QueueName) -> TestTree test_core getQueueParams = testGroup "Core Tests" [ eitherTOnceTest0 "connectionReuse" $ do (_, queue) <- liftIO getQueueParams prop_connectionReuse queue ] prop_connectionReuse :: SQS.QueueName -> ExceptT T.Text IO () prop_connectionReuse queue = do c <- liftIO $ do cfg <- baseConfiguration -- used for counting the number of TCP connections ref <- newIORef (0 :: Int) -- Use a single manager for all HTTP requests void . HTTP.withManager (managerSettings ref) $ \manager -> runExceptT $ flip catchE (error . T.unpack) . replicateM_ 3 $ do void . sqsT cfg manager $ SQS.ListQueues Nothing mustFail . sqsT cfg manager $ SQS.SendMessage "" (SQS.QueueName "" "") [] Nothing void . sqsT cfg manager $ SQS.SendMessage "test-message" queue [] Nothing void . sqsT cfg manager $ SQS.ReceiveMessage Nothing [] Nothing [] queue (Just 20) readIORef ref unless (c == 1) $ throwE "The TCP connection has not been reused" where managerSettings ref = HTTP.defaultManagerSettings { HTTP.managerRawConnection = do mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings return $ \a b c -> do atomicModifyIORef ref $ \i -> (succ i, ()) mkConn a b c } aws-0.13.0/tests/DynamoDb/0000755000000000000000000000000012615132266013416 5ustar0000000000000000aws-0.13.0/tests/DynamoDb/Utils.hs0000644000000000000000000001077212615132266015061 0ustar0000000000000000-- ------------------------------------------------------ -- -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module: DynamoDb.Utils -- Copyright: Copyright © 2014 AlephCloud Systems, Inc. -- License: BSD3 -- Maintainer: Lars Kuhtz -- Stability: experimental -- -- Tests for Haskell SQS bindings -- module DynamoDb.Utils ( -- * Static Parameters testProtocol , testRegion , defaultTableName -- * Static Configuration , dyConfiguration -- * DynamoDb Utils , simpleDy , simpleDyT , dyT , withTable , withTable_ , createTestTable ) where import Aws import Aws.Core import qualified Aws.DynamoDb as DY import Control.Error import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import Data.Monoid import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Network.HTTP.Client as HTTP import Test.Tasty import Test.QuickCheck.Instances () import System.IO import Utils -- -------------------------------------------------------------------------- -- -- Static Test parameters -- -- TODO make these configurable testProtocol :: Protocol testProtocol = HTTP testRegion :: DY.Region testRegion = DY.ddbUsWest2 defaultTableName :: T.Text defaultTableName = "test-table" -- -------------------------------------------------------------------------- -- -- Dynamo Utils dyConfiguration :: DY.DdbConfiguration qt dyConfiguration = DY.DdbConfiguration { DY.ddbcRegion = testRegion , DY.ddbcProtocol = testProtocol , DY.ddbcPort = Nothing } simpleDy :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadIO m) => r -> m (MemoryResponse a) simpleDy command = do c <- dbgConfiguration simpleAws c dyConfiguration command simpleDyT :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadBaseControl IO m, MonadIO m) => r -> ExceptT T.Text m (MemoryResponse a) simpleDyT = tryT . simpleDy dyT :: (Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration) => Configuration -> HTTP.Manager -> r -> ExceptT T.Text IO a dyT cfg manager req = do Response _ r <- liftIO . runResourceT $ aws cfg dyConfiguration manager req hoistEither $ fmapL sshow r withTable :: T.Text -- ^ table Name -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) -> Int -- ^ write capacity (#writes * itemsize/1KB) -> (T.Text -> IO a) -- ^ test tree -> IO a withTable = withTable_ True withTable_ :: Bool -- ^ whether to prefix te table name -> T.Text -- ^ table Name -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) -> Int -- ^ write capacity (#writes * itemsize/1KB) -> (T.Text -> IO a) -- ^ test tree -> IO a withTable_ prefix tableName readCapacity writeCapacity f = do tTableName <- if prefix then testData tableName else return tableName let deleteTable = do r <- runExceptT . retryT 6 $ void (simpleDyT $ DY.DeleteTable tTableName) `catchE` \e -> liftIO . T.hPutStrLn stderr $ "attempt to delete table failed: " <> e either (error . T.unpack) (const $ return ()) r let createTable = do r <- runExceptT $ do retryT 3 $ tryT $ createTestTable tTableName readCapacity writeCapacity retryT 6 $ do tableDesc <- simpleDyT $ DY.DescribeTable tTableName when (DY.rTableStatus tableDesc == "CREATING") $ throwE "Table not ready: status CREATING" either (error . T.unpack) return r bracket_ createTable deleteTable $ f tTableName createTestTable :: T.Text -- ^ table Name -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) -> Int -- ^ write capacity (#writes * itemsize/1KB) -> IO () createTestTable tableName readCapacity writeCapacity = void . simpleDy $ DY.createTable tableName attrs (DY.HashOnly keyName) throughPut where keyName = "Id" keyType = DY.AttrString attrs = [DY.AttributeDefinition keyName keyType] throughPut = DY.ProvisionedThroughput { DY.readCapacityUnits = readCapacity , DY.writeCapacityUnits = writeCapacity } aws-0.13.0/tests/DynamoDb/Main.hs0000644000000000000000000001063612615132266014644 0ustar0000000000000000-- ------------------------------------------------------ -- -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module: Main -- Copyright: Copyright © 2014 AlephCloud Systems, Inc. -- License: BSD3 -- Maintainer: Lars Kuhtz -- Stability: experimental -- -- Tests for Haskell AWS DynamoDb bindings -- module Main ( main ) where import Aws import qualified Aws.DynamoDb as DY import Control.Arrow (second) import Control.Error import Control.Monad import Control.Monad.IO.Class import Data.IORef import qualified Data.List as L import qualified Data.Text as T import qualified Network.HTTP.Client as HTTP import Test.Tasty import Test.QuickCheck.Instances () import System.Environment import System.Exit import Utils import DynamoDb.Utils -- -------------------------------------------------------------------------- -- -- Main main :: IO () main = do args <- getArgs runMain args $ map (second tail . span (/= '=')) args where runMain :: [String] -> [(String,String)] -> IO () runMain args _argsMap | any (`elem` helpArgs) args = defaultMain tests | "--run-with-aws-credentials" `elem` args = withArgs (tastyArgs args) . defaultMain $ tests | otherwise = putStrLn help >> exitFailure helpArgs = ["--help", "-h"] mainArgs = [ "--run-with-aws-credentials" ] tastyArgs args = flip filter args $ \x -> not $ any (`L.isPrefixOf` x) mainArgs help :: String help = L.intercalate "\n" [ "" , "NOTE" , "" , "This test suite accesses the AWS account that is associated with" , "the default credentials from the credential file ~/.aws-keys." , "" , "By running the tests in this test-suite costs for usage of AWS" , "services may incur." , "" , "In order to actually excute the tests in this test-suite you must" , "provide the command line options:" , "" , " --run-with-aws-credentials" , "" , "When running this test-suite through cabal you may use the following" , "command:" , "" , " cabal test --test-option=--run-with-aws-credentials dynamodb-tests" , "" ] tests :: TestTree tests = testGroup "DynamoDb Tests" [ test_table -- , test_message , test_core ] -- -------------------------------------------------------------------------- -- -- Table Tests test_table :: TestTree test_table = testGroup "Table Tests" [ eitherTOnceTest1 "CreateDescribeDeleteTable" (prop_createDescribeDeleteTable 10 10) ] -- | -- prop_createDescribeDeleteTable :: Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) -> Int -- ^ write capacity (#writes * itemsize/1KB) -> T.Text -- ^ table name -> ExceptT T.Text IO () prop_createDescribeDeleteTable readCapacity writeCapacity tableName = do tTableName <- testData tableName tryT $ createTestTable tTableName readCapacity writeCapacity let deleteTable = retryT 6 . void $ simpleDyT (DY.DeleteTable tTableName) flip catchE (\e -> deleteTable >> throwE e) $ do retryT 6 . void . simpleDyT $ DY.DescribeTable tTableName deleteTable -- -------------------------------------------------------------------------- -- -- Test core functionality test_core :: TestTree test_core = testGroup "Core Tests" [ eitherTOnceTest0 "connectionReuse" prop_connectionReuse ] prop_connectionReuse :: ExceptT T.Text IO () prop_connectionReuse = do c <- liftIO $ do cfg <- baseConfiguration -- counts the number of TCP connections ref <- newIORef (0 :: Int) void . HTTP.withManager (managerSettings ref) $ \manager -> runExceptT $ flip catchE (error . T.unpack) . replicateM_ 3 $ do void $ dyT cfg manager DY.ListTables mustFail . dyT cfg manager $ DY.DescribeTable "____" readIORef ref unless (c == 1) $ throwE "The TCP connection has not been reused" where managerSettings ref = HTTP.defaultManagerSettings { HTTP.managerRawConnection = do mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings return $ \a b c -> do atomicModifyIORef ref $ \i -> (succ i, ()) mkConn a b c }