aws-ec2 (empty) → 0.1
raw patch · 55 files changed
+2184/−0 lines, 55 filesdep +aesondep +awsdep +aws-ec2setup-changed
Dependencies added: aeson, aws, aws-ec2, base, base16-bytestring, base64-bytestring, blaze-builder, byteable, bytestring, conduit-extra, containers, cryptohash, http-conduit, http-types, mtl, optparse-applicative, resourcet, scientific, template-haskell, text, time, unordered-containers, vector, xml-conduit
Files
- LICENSE +51/−0
- Setup.hs +2/−0
- aws-ec2.cabal +123/−0
- cmd/put-metric.hs +77/−0
- src/Aws/Canonical.hs +15/−0
- src/Aws/CloudWatch.hs +13/−0
- src/Aws/CloudWatch/Commands/PutMetricData.hs +70/−0
- src/Aws/CloudWatch/Core.hs +23/−0
- src/Aws/CloudWatch/Types.hs +37/−0
- src/Aws/Ec2.hs +79/−0
- src/Aws/Ec2/Commands/AttachInternetGateway.hs +28/−0
- src/Aws/Ec2/Commands/AttachVolume.hs +30/−0
- src/Aws/Ec2/Commands/AuthorizeSecurityGroupIngress.hs +53/−0
- src/Aws/Ec2/Commands/CreateInternetGateway.hs +23/−0
- src/Aws/Ec2/Commands/CreateRoute.hs +38/−0
- src/Aws/Ec2/Commands/CreateSecurityGroup.hs +28/−0
- src/Aws/Ec2/Commands/CreateSubnet.hs +29/−0
- src/Aws/Ec2/Commands/CreateTags.hs +36/−0
- src/Aws/Ec2/Commands/CreateVolume.hs +27/−0
- src/Aws/Ec2/Commands/CreateVpc.hs +27/−0
- src/Aws/Ec2/Commands/DescribeAvailabilityZones.hs +13/−0
- src/Aws/Ec2/Commands/DescribeImages.hs +23/−0
- src/Aws/Ec2/Commands/DescribeInstanceStatus.hs +16/−0
- src/Aws/Ec2/Commands/DescribeInstances.hs +24/−0
- src/Aws/Ec2/Commands/DescribeKeyPairs.hs +13/−0
- src/Aws/Ec2/Commands/DescribeRegions.hs +13/−0
- src/Aws/Ec2/Commands/DescribeRouteTables.hs +25/−0
- src/Aws/Ec2/Commands/DescribeSecurityGroups.hs +30/−0
- src/Aws/Ec2/Commands/DescribeSubnets.hs +13/−0
- src/Aws/Ec2/Commands/DescribeTags.hs +13/−0
- src/Aws/Ec2/Commands/DescribeVolumeStatus.hs +13/−0
- src/Aws/Ec2/Commands/DescribeVolumes.hs +13/−0
- src/Aws/Ec2/Commands/DescribeVpcs.hs +13/−0
- src/Aws/Ec2/Commands/GetConsoleOutput.hs +32/−0
- src/Aws/Ec2/Commands/ImportKeyPair.hs +28/−0
- src/Aws/Ec2/Commands/ModifyVpcAttribute.hs +31/−0
- src/Aws/Ec2/Commands/RunInstances.hs +91/−0
- src/Aws/Ec2/Core.hs +38/−0
- src/Aws/Ec2/TH.hs +32/−0
- src/Aws/Ec2/Types.hs +99/−0
- src/Aws/Elb.hs +27/−0
- src/Aws/Elb/Commands/CreateLoadBalancer.hs +59/−0
- src/Aws/Elb/Commands/DescribeInstanceHealth.hs +22/−0
- src/Aws/Elb/Commands/DescribeLoadBalancerPolicies.hs +22/−0
- src/Aws/Elb/Commands/DescribeLoadBalancerPolicyTypes.hs +36/−0
- src/Aws/Elb/Commands/DescribeLoadBalancers.hs +15/−0
- src/Aws/Elb/Commands/ModifyLoadBalancerAttributes.hs +56/−0
- src/Aws/Elb/Commands/RegisterInstancesWithLoadBalancer.hs +32/−0
- src/Aws/Elb/Core.hs +36/−0
- src/Aws/Elb/TH.hs +39/−0
- src/Aws/Elb/Types.hs +17/−0
- src/Aws/Query.hs +245/−0
- src/Aws/Query/TH.hs +56/−0
- src/Aws/Query/Types.hs +96/−0
- src/Aws/TH.hs +44/−0
+ LICENSE view
@@ -0,0 +1,51 @@+Copyright (c) 2014 Vladimir Kirillov <proger@hackndev.com>+Copyright (c) 2014 Zalora++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.++Code portions are inherited from https://github.com/aristidb/aws,+and are copyrighted by and/or attributed to the following contributors:+https://github.com/aristidb/aws#contributors+++Copyright (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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aws-ec2.cabal view
@@ -0,0 +1,123 @@+name: aws-ec2+version: 0.1+synopsis: AWS EC2/VPC, ELB and CloudWatch client library for Haskell+license-file: LICENSE+license: BSD3+author: Vladimir Kirillov+maintainer: vlad.ki@zalora.com+copyright: See contributors list in README and LICENSE file+build-type: Simple+cabal-version: >=1.10+category: Network, Web, AWS, Cloud, Distributed Computing+homepage: https://github.com/zalora/aws-ec2+description: AWS client library with focus on infrastructure services like EC2 (with VPC), ELB and CloudWatch, extension to <https://github.com/aristidb/aws>.++source-repository this+ type: git+ location: https://github.com/zalora/aws-ec2.git+ tag: 0.1++source-repository head+ type: git+ location: https://github.com/zalora/aws-ec2.git++library+ exposed-modules:+ Aws.Canonical++ , Aws.Query+ , Aws.Query.TH+ , Aws.Query.Types+ , Aws.TH++ , Aws.CloudWatch+ , Aws.CloudWatch.Core+ , Aws.CloudWatch.Types+ , Aws.CloudWatch.Commands.PutMetricData++ , Aws.Ec2+ , Aws.Ec2.Core+ , Aws.Ec2.TH+ , Aws.Ec2.Types+ , Aws.Ec2.Commands.AttachInternetGateway+ , Aws.Ec2.Commands.AttachVolume+ , Aws.Ec2.Commands.AuthorizeSecurityGroupIngress+ , Aws.Ec2.Commands.CreateInternetGateway+ , Aws.Ec2.Commands.CreateRoute+ , Aws.Ec2.Commands.CreateSecurityGroup+ , Aws.Ec2.Commands.CreateSubnet+ , Aws.Ec2.Commands.CreateTags+ , Aws.Ec2.Commands.CreateVolume+ , Aws.Ec2.Commands.CreateVpc+ , Aws.Ec2.Commands.DescribeAvailabilityZones+ , Aws.Ec2.Commands.DescribeImages+ , Aws.Ec2.Commands.DescribeInstanceStatus+ , Aws.Ec2.Commands.DescribeInstances+ , Aws.Ec2.Commands.DescribeKeyPairs+ , Aws.Ec2.Commands.DescribeRegions+ , Aws.Ec2.Commands.DescribeRouteTables+ , Aws.Ec2.Commands.DescribeSecurityGroups+ , Aws.Ec2.Commands.DescribeSubnets+ , Aws.Ec2.Commands.DescribeTags+ , Aws.Ec2.Commands.DescribeVolumeStatus+ , Aws.Ec2.Commands.DescribeVolumes+ , Aws.Ec2.Commands.DescribeVpcs+ , Aws.Ec2.Commands.GetConsoleOutput+ , Aws.Ec2.Commands.ImportKeyPair+ , Aws.Ec2.Commands.ModifyVpcAttribute+ , Aws.Ec2.Commands.RunInstances++ , Aws.Elb+ , Aws.Elb.Core+ , Aws.Elb.TH+ , Aws.Elb.Types+ , Aws.Elb.Commands.CreateLoadBalancer+ , Aws.Elb.Commands.DescribeInstanceHealth+ , Aws.Elb.Commands.DescribeLoadBalancerPolicies+ , Aws.Elb.Commands.DescribeLoadBalancerPolicyTypes+ , Aws.Elb.Commands.DescribeLoadBalancers+ , Aws.Elb.Commands.ModifyLoadBalancerAttributes+ , Aws.Elb.Commands.RegisterInstancesWithLoadBalancer+ build-depends:+ base >=4 && <5+ , template-haskell+ , containers+ , mtl+ , text+ , bytestring+ , base16-bytestring+ , base64-bytestring+ , blaze-builder+ , time++ , aeson+ , unordered-containers+ , vector+ , scientific++ , resourcet+ , byteable+ , cryptohash+ , http-types+ , http-conduit+ , conduit-extra+ , xml-conduit+ , aws >= 0.9.3++ hs-source-dirs: src+ default-language: Haskell2010+ default-extensions: OverloadedStrings, TemplateHaskell++executable put-metric+ main-is: put-metric.hs+ build-depends:+ base+ , bytestring+ , text+ , optparse-applicative+ , aws >= 0.9.3+ , aws-ec2++ hs-source-dirs: cmd+ default-language: Haskell2010+ default-extensions: OverloadedStrings
+ cmd/put-metric.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}++module Main where++import Control.Monad+import Options.Applicative++import qualified Data.ByteString.Char8 as B+import qualified Data.Text as T++import qualified Aws+import Aws (Configuration(..), LogLevel(..), defaultLog)+import Aws.CloudWatch++configuration :: Bool -> IO Configuration+configuration useMetadata = do+ cr <- load+ case cr of+ Nothing -> error "could not locate aws credentials"+ Just cr' -> return Configuration { timeInfo = Timestamp+ , credentials = cr'+ , logger = defaultLog Warning+ }+ where+ load = if useMetadata then loadCredentialsFromInstanceMetadata+ else loadCredentialsDefault++put :: String -> String -> String -> Double -> Unit -> String -> Bool -> IO ()+put region namespace name value unit iodims useMetadata = do+ cfg <- configuration useMetadata+ m <- metric+ Aws.simpleAws cfg (QueryAPIConfiguration $ B.pack region) $ PutMetricData (T.pack namespace) [m]+ return ()+ where+ metric = do+ dimensions <- pairs iodims+ return MetricDatum { md_dimensions = fmap (\(name, value) -> Dimension name value) dimensions+ , md_metricName = T.pack name+ , md_timestamp = Nothing+ , md_unit = Just unit+ , md_value = MetricValue value+ }++pairs :: Monad m => String -> m [(Text, Text)]+pairs = return . concat . fmap (group . T.split (== '=')) . T.split (== ',') . T.pack+ where+ group (x:y:xs) = (x,y) : group xs+ group [] = []+ group _ = fail "could not match pairs"++units :: IO ()+units = mapM_ print $ enumFrom Seconds++main = join $ customExecParser prefs opts+ where+ prefs = ParserPrefs { prefMultiSuffix = ""+ , prefDisambiguate = True+ , prefShowHelpOnError = True+ , prefBacktrack = True+ , prefColumns = 80+ }++ opts = parser `info` header "AWS CloudWatch PutMetricData client"++ parser = subparser (command "value" (args put `info` progDesc "put a value metric") <>+ command "units" (pure units `info` progDesc "list all metric units")+ )++ args comm = comm <$> argument str (metavar "<region>")+ <*> argument str (metavar "<namespace>")+ <*> argument str (metavar "<metric name>")+ <*> argument auto (metavar "<double value>")+ <*> argument auto (metavar "<unit>")+ <*> argument str (metavar "dimension1=value1")+ <*> switch (short 'm' <>+ long "metadata" <>+ help "Use instance metadata to get authentication info")
+ src/Aws/Canonical.hs view
@@ -0,0 +1,15 @@+module Aws.Canonical where++import Data.IORef+import Data.Time.Clock+import Aws.Core++canonicalSigData :: IO SignatureData+canonicalSigData = do+ emptyRef <- newIORef []+ return SignatureData { signatureTimeInfo = AbsoluteTimestamp baseTime+ , signatureTime = baseTime+ , signatureCredentials = Credentials "" "" emptyRef Nothing+ }++baseTime = UTCTime (toEnum 0) $ secondsToDiffTime 0
+ src/Aws/CloudWatch.hs view
@@ -0,0 +1,13 @@+module Aws.CloudWatch (+ module Aws.Query.Types+, module Aws.CloudWatch.Types+, module Aws.CloudWatch.Core++, module Aws.CloudWatch.Commands.PutMetricData+) where++import Aws.Query.Types+import Aws.CloudWatch.Types+import Aws.CloudWatch.Core++import Aws.CloudWatch.Commands.PutMetricData
+ src/Aws/CloudWatch/Commands/PutMetricData.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.CloudWatch.Commands.PutMetricData where++import Data.Text (Text)+import Data.Monoid+import Data.Time.Clock (UTCTime)+import Aws.CloudWatch.Core+import Aws.CloudWatch.Types++data Dimension = Dimension { di_name :: Text+ , di_value :: Text+ } deriving (Show, Eq)++data MetricDatum = MetricDatum { md_dimensions :: [Dimension]+ , md_metricName :: Text+ , md_timestamp :: Maybe UTCTime+ , md_unit :: Maybe Unit+ , md_value :: MetricDatumValue+ } deriving (Show, Eq)++data MetricDatumValue = MetricValue Double+ | MetricStatisticValue StatisticSet+ deriving (Show, Eq)++data StatisticSet = StatisticSet { ss_maximum :: Double+ , ss_minimum :: Double+ , ss_sampleCount :: Double+ , ss_sum :: Double+ } deriving (Show, Eq)++data PutMetricData = PutMetricData Text [MetricDatum]+ deriving (Show)++enumerateDimensions :: [Dimension] -> Query+enumerateDimensions = enumerateLists "Dimensions.member." . fmap unroll+ where+ unroll Dimension{..} = [ ("Name", qArg di_name)+ , ("Value", qArg di_value)+ ]++enumerateMetrics :: [MetricDatum] -> Query+enumerateMetrics = enumerateLists "MetricData.member." . fmap unroll+ where+ unroll MetricDatum{..} = [ ("MetricName", qArg md_metricName)+ ] +++ optional "Timestamp" md_timestamp qShow+ +++ optional "Unit" md_unit qShow+ +++ enumerateDimensions md_dimensions+ +++ case md_value of+ MetricValue v -> [("Value", qShow v)]+ MetricStatisticValue StatisticSet{..} -> [ ("StatisticValues.Maximum", qShow ss_maximum)+ , ("StatisticValues.Minimum", qShow ss_minimum)+ , ("StatisticValues.SampleCount", qShow ss_sampleCount)+ , ("StatisticValues.Sum", qShow ss_sum)+ ]++instance SignQuery PutMetricData where+ type ServiceConfiguration PutMetricData = QueryAPIConfiguration+ signQuery (PutMetricData namespace xs) = cwSignQuery $ [ ("Action", qArg "PutMetricData")+ , ("Version", qArg "2010-08-01")+ , ("Namespace", qArg namespace)+ ] +++ enumerateMetrics xs++queryValueTransaction ''PutMetricData "PutMetricDataResponse"
+ src/Aws/CloudWatch/Core.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE RecordWildCards #-}++module Aws.CloudWatch.Core (+ module Network.HTTP.Types+, module Aws.Core+, module Aws.Query+, module Aws.Query.TH+, cwSignQuery+) where++import qualified Data.ByteString as B+import Network.HTTP.Types hiding (Method)+import Aws.Core+import Aws.Query+import Aws.Query.TH++cwSignQuery :: Query -> QueryAPIConfiguration qt -> SignatureData -> SignedQuery+cwSignQuery query QueryAPIConfiguration{..} sd = v2SignQuery query qd sd+ where+ qd = QueryData { qdRegion = qaRegion+ , qdEndpoint = B.concat ["monitoring.", qaRegion, ".amazonaws.com"]+ , qdService = ""+ }
+ src/Aws/CloudWatch/Types.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TemplateHaskell #-}++module Aws.CloudWatch.Types where++import Aws.TH+import Data.Monoid (mconcat) -- needed by derivePatchedShowRead++data Unit = Seconds+ | Microseconds+ | Milliseconds+ | Bytes+ | Kilobytes+ | Megabytes+ | Gigabytes+ | Terabytes+ | Bits+ | Kilobits+ | Megabits+ | Gigabits+ | Terabits+ | Percent+ | Count+ | BytesPerSecond+ | KilobytesPerSecond+ | MegabytesPerSecond+ | GigabytesPerSecond+ | TerabytesPerSecond+ | BitsPerSecond+ | KilobitsPerSecond+ | MegabitsPerSecond+ | GigabitsPerSecond+ | TerabitsPerSecond+ | CountPerSecond+ | None+ deriving (Eq, Enum)++derivePatchedShowRead ''Unit patchPer
+ src/Aws/Ec2.hs view
@@ -0,0 +1,79 @@+module Aws.Ec2 (+ Transaction+, module Aws.Query.Types+, module Aws.Ec2.Types+, module Aws.Ec2.Core++, module Aws.Ec2.Commands.DescribeAvailabilityZones+, module Aws.Ec2.Commands.DescribeRegions+, module Aws.Ec2.Commands.DescribeImages++, module Aws.Ec2.Commands.DescribeSecurityGroups+, module Aws.Ec2.Commands.CreateSecurityGroup+, module Aws.Ec2.Commands.AuthorizeSecurityGroupIngress++, module Aws.Ec2.Commands.CreateTags+, module Aws.Ec2.Commands.DescribeTags+, module Aws.Ec2.Commands.DescribeKeyPairs+, module Aws.Ec2.Commands.ImportKeyPair++, module Aws.Ec2.Commands.DescribeInstances+, module Aws.Ec2.Commands.DescribeInstanceStatus+, module Aws.Ec2.Commands.RunInstances+, module Aws.Ec2.Commands.GetConsoleOutput++, module Aws.Ec2.Commands.DescribeVpcs+, module Aws.Ec2.Commands.CreateVpc+, module Aws.Ec2.Commands.ModifyVpcAttribute+, module Aws.Ec2.Commands.CreateInternetGateway+, module Aws.Ec2.Commands.AttachInternetGateway+, module Aws.Ec2.Commands.DescribeRouteTables+, module Aws.Ec2.Commands.CreateRoute++, module Aws.Ec2.Commands.DescribeSubnets+, module Aws.Ec2.Commands.CreateSubnet++, module Aws.Ec2.Commands.DescribeVolumes+, module Aws.Ec2.Commands.DescribeVolumeStatus+, module Aws.Ec2.Commands.CreateVolume+, module Aws.Ec2.Commands.AttachVolume+) where++import Aws.Core (Transaction)+import Aws.Query.Types+import Aws.Ec2.Types+import Aws.Ec2.Core++import Aws.Ec2.Commands.DescribeAvailabilityZones+import Aws.Ec2.Commands.DescribeRegions+import Aws.Ec2.Commands.DescribeImages++import Aws.Ec2.Commands.DescribeSecurityGroups+import Aws.Ec2.Commands.CreateSecurityGroup+import Aws.Ec2.Commands.AuthorizeSecurityGroupIngress++import Aws.Ec2.Commands.CreateTags+import Aws.Ec2.Commands.DescribeTags+import Aws.Ec2.Commands.DescribeKeyPairs+import Aws.Ec2.Commands.ImportKeyPair++import Aws.Ec2.Commands.DescribeInstances+import Aws.Ec2.Commands.DescribeInstanceStatus+import Aws.Ec2.Commands.RunInstances+import Aws.Ec2.Commands.GetConsoleOutput++import Aws.Ec2.Commands.DescribeVpcs+import Aws.Ec2.Commands.CreateVpc+import Aws.Ec2.Commands.ModifyVpcAttribute+import Aws.Ec2.Commands.CreateInternetGateway+import Aws.Ec2.Commands.AttachInternetGateway+import Aws.Ec2.Commands.DescribeRouteTables+import Aws.Ec2.Commands.CreateRoute++import Aws.Ec2.Commands.DescribeSubnets+import Aws.Ec2.Commands.CreateSubnet++import Aws.Ec2.Commands.DescribeVolumes+import Aws.Ec2.Commands.DescribeVolumeStatus+import Aws.Ec2.Commands.CreateVolume+import Aws.Ec2.Commands.AttachVolume
+ src/Aws/Ec2/Commands/AttachInternetGateway.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.AttachInternetGateway where++import Data.Text (Text, pack, toLower)+import Aws.Ec2.TH++data AttachInternetGateway = AttachInternetGateway+ { aig_internetGatewayId :: Text+ , aig_vpcId :: Text+ } deriving (Show)++instance SignQuery AttachInternetGateway where+ type ServiceConfiguration AttachInternetGateway = EC2Configuration+ signQuery AttachInternetGateway{..} = ec2SignQuery $+ [ ("InternetGatewayId", qArg aig_internetGatewayId)+ , ("VpcId", qArg aig_vpcId)+ , ("Action", qArg "AttachInternetGateway")+ , defVersion+ ]++ec2ValueTransaction ''AttachInternetGateway "return"
+ src/Aws/Ec2/Commands/AttachVolume.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.AttachVolume where++import Data.Text (Text)+import Data.Monoid+import Aws.Ec2.TH++data AttachVolume = AttachVolume+ { avol_volumeId :: Text+ , avol_instanceId :: Text+ , avol_device :: Text+ } deriving (Show)++instance SignQuery AttachVolume where+ type ServiceConfiguration AttachVolume = EC2Configuration+ signQuery AttachVolume{..} = ec2SignQuery $ [ ("Action", qArg "AttachVolume")+ , defVersion+ , ("VolumeId", qArg avol_volumeId)+ , ("InstanceId", qArg avol_instanceId)+ , ("Device", qArg avol_device)+ ]++ec2ValueTransaction ''AttachVolume "AttachVolumeResponse"
+ src/Aws/Ec2/Commands/AuthorizeSecurityGroupIngress.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.AuthorizeSecurityGroupIngress where++import qualified Network.HTTP.Types as HTTP+import Data.Monoid (mconcat)+import Data.Text (Text)+import Data.ByteString.Char8 (pack, ByteString)+import Aws.Ec2.TH++data IpProtocol = TCP | UDP | ICMP | Proto Int | All++instance Show IpProtocol where+ show TCP = "tcp" -- 6+ show UDP = "udp" -- 17+ show ICMP = "icmp" -- 1+ show (Proto i) = show i+ show All = "-1"++type CidrIp = Text++data IpPermission = IpPermission IpProtocol (Maybe Int) (Maybe Int) [CidrIp]+ deriving (Show)++data AuthorizeSecurityGroupIngress = AuthorizeSecurityGroupIngress+ { asi_groupId :: Text+ , asi_permissions :: [IpPermission]+ } deriving (Show)++enumeratePermissions :: [IpPermission] -> HTTP.Query+enumeratePermissions = enumerateLists "IpPermissions." . fmap unroll+ where+ unroll (IpPermission proto from to ips) = [ ("IpProtocol", qShow proto)+ , ("FromPort", qShow $ maybe (-1) id from)+ , ("ToPort", qShow $ maybe (-1) id to)+ ] +++ [(mconcat [k, ".CidrIp"], v)| (k, v) <- enumerate "IpRanges" ips qArg]+++instance SignQuery AuthorizeSecurityGroupIngress where+ type ServiceConfiguration AuthorizeSecurityGroupIngress = EC2Configuration+ signQuery AuthorizeSecurityGroupIngress{..} = ec2SignQuery $+ [ ("GroupId", qArg asi_groupId)+ , ("Action", qArg "AuthorizeSecurityGroupIngress")+ , defVersion+ ] +++ enumeratePermissions asi_permissions++ec2ValueTransaction ''AuthorizeSecurityGroupIngress "AuthorizeSecurityGroupIngressResponse"
+ src/Aws/Ec2/Commands/CreateInternetGateway.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.CreateInternetGateway where++import Aws.Ec2.TH++data CreateInternetGateway = CreateInternetGateway+ deriving (Show)++instance SignQuery CreateInternetGateway where+ type ServiceConfiguration CreateInternetGateway = EC2Configuration+ signQuery CreateInternetGateway{..} = ec2SignQuery $ + [ ("Action", qArg "CreateInternetGateway")+ , defVersion+ ]++ec2ValueTransaction ''CreateInternetGateway "internetGateway"
+ src/Aws/Ec2/Commands/CreateRoute.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , TemplateHaskell+ , RecordWildCards+ #-}++-- | Optimized to lookup a default route table for VPC.++module Aws.Ec2.Commands.CreateRoute where++import Aws.Ec2.TH++data RouteTarget = GatewayId Text+ | InstanceId Text+ | NetworkInterfaceId Text+ | VpcPeeringConnectionId Text+ deriving (Show)++data CreateRoute = CreateRoute+ { cr_routeTableId :: Text+ , cr_destinationCidrBlock :: Text+ , cr_target :: RouteTarget+ } deriving (Show)++instance SignQuery CreateRoute where+ type ServiceConfiguration CreateRoute = EC2Configuration+ signQuery CreateRoute{..} = ec2SignQuery $+ [ ("Action", qArg "CreateRoute")+ , defVersion+ , ("RouteTableId", qArg cr_routeTableId)+ , ("DestinationCidrBlock", qArg cr_destinationCidrBlock)+ ] +++ case cr_target of+ GatewayId t -> [("GatewayId", qArg t)]+ InstanceId t -> [("InstanceId", qArg t)]+ NetworkInterfaceId t -> [("NetworkInterfaceId", qArg t)]+ VpcPeeringConnectionId t -> [("VpcPeeringConnectionId", qArg t)]++ec2ValueTransaction ''CreateRoute "return"
+ src/Aws/Ec2/Commands/CreateSecurityGroup.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.CreateSecurityGroup where++import Aws.Ec2.TH++data CreateSecurityGroup = CreateSecurityGroup+ { csec_name :: Text+ , csec_description :: Text+ , csec_vpcId :: Maybe Text+ } deriving (Show)++instance SignQuery CreateSecurityGroup where+ type ServiceConfiguration CreateSecurityGroup = EC2Configuration+ signQuery CreateSecurityGroup{..} = ec2SignQuery $+ [ ("GroupName", qArg csec_name)+ , ("GroupDescription", qArg csec_description)+ , ("Action", qArg "CreateSecurityGroup")+ , defVersion+ ] +++ optionalA "VpcId" csec_vpcId++ec2ValueTransaction ''CreateSecurityGroup "CreateSecurityGroupResponse"
+ src/Aws/Ec2/Commands/CreateSubnet.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.CreateSubnet where++import Data.Text (Text)+import Aws.Ec2.TH++data CreateSubnet = CreateSubnet+ { csub_vpcId :: Text+ , csub_cidrBlock :: Text+ , csub_availabilityZone :: Maybe Text+ } deriving (Show)++instance SignQuery CreateSubnet where+ type ServiceConfiguration CreateSubnet = EC2Configuration+ signQuery CreateSubnet{..} = ec2SignQuery $+ [ ("Action", qArg "CreateSubnet")+ , defVersion+ , ("VpcId", qArg csub_vpcId)+ , ("CidrBlock", qArg csub_cidrBlock)+ ] +++ (optionalA "AvailabilityZone" csub_availabilityZone)++ec2ValueTransaction ''CreateSubnet "subnet"
+ src/Aws/Ec2/Commands/CreateTags.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.CreateTags where++import Aws.Ec2.TH+import qualified Network.HTTP.Types as HTTP++type Tag = (Text, Text)++data CreateTags = CreateTags+ { ct_resources :: [Text]+ , ct_tags :: [Tag]+ } deriving (Show)++enumerateTags :: [Tag] -> HTTP.Query+enumerateTags = enumerateLists "Tag." . fmap unroll+ where+ unroll (key, value) = [ ("Key", qArg key)+ , ("Value", qArg value)+ ]++instance SignQuery CreateTags where+ type ServiceConfiguration CreateTags = EC2Configuration+ signQuery CreateTags{..} = ec2SignQuery $+ [ ("Action", qArg "CreateTags")+ , defVersion+ ] +++ enumerate "ResourceId" ct_resources qArg+ +++ enumerateTags ct_tags++ec2ValueTransaction ''CreateTags "return"
+ src/Aws/Ec2/Commands/CreateVolume.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.CreateVolume where++import Data.Text (Text)+import Data.Monoid+import Aws.Ec2.TH++data CreateVolume = CreateVolume+ { cvol_AvailabilityZone :: Text+ , cvol_ebs :: EbsBlockDevice+ } deriving (Show)++instance SignQuery CreateVolume where+ type ServiceConfiguration CreateVolume = EC2Configuration+ signQuery CreateVolume{..} = ec2SignQuery $ [ ("Action", qArg "CreateVolume")+ , defVersion+ , ("AvailabilityZone", qArg cvol_AvailabilityZone)+ ] ++ queryEbsBlockDevice cvol_ebs++ec2ValueTransaction ''CreateVolume "CreateVolumeResponse"
+ src/Aws/Ec2/Commands/CreateVpc.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.CreateVpc where++import Data.Text (Text, pack, toLower)+import Aws.Ec2.TH++data CreateVpc = CreateVpc+ { cvpc_cidrBlock :: Text+ , cvpc_instanceTenancy :: InstanceTenancy+ } deriving (Show)++instance SignQuery CreateVpc where+ type ServiceConfiguration CreateVpc = EC2Configuration+ signQuery CreateVpc{..} = ec2SignQuery [ ("CidrBlock", qArg cvpc_cidrBlock)+ , ("InstanceTenancy", qArg $ toLower $ pack $ show cvpc_instanceTenancy)+ , ("Action", qArg "CreateVpc")+ , defVersion+ ]++ec2ValueTransaction ''CreateVpc "vpc"
+ src/Aws/Ec2/Commands/DescribeAvailabilityZones.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ #-}++module Aws.Ec2.Commands.DescribeAvailabilityZones where++import Aws.Ec2.TH++data DescribeAvailabilityZones = DescribeAvailabilityZones [Text]+ deriving (Show)++ec2ValueTransactionDef ''DescribeAvailabilityZones 'DescribeAvailabilityZones "availabilityZoneInfo" "ZoneName"
+ src/Aws/Ec2/Commands/DescribeImages.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ , RecordWildCards+ #-}++module Aws.Ec2.Commands.DescribeImages where++import Aws.Ec2.TH++data DescribeImages = DescribeImages { di_imageIds :: [Text] }+ deriving (Show)++instance SignQuery DescribeImages where+ type ServiceConfiguration DescribeImages = EC2Configuration+ signQuery DescribeImages{..} = ec2SignQuery $+ [ ("Action", qArg "DescribeImages")+ , defVersion+ ] +++ case di_imageIds of+ [] -> [("Owner.1", qArg "self")]+ _ -> enumerate "ImageId" di_imageIds qArg++ec2ValueTransaction ''DescribeImages "imagesSet"
+ src/Aws/Ec2/Commands/DescribeInstanceStatus.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ , RecordWildCards+ #-}++module Aws.Ec2.Commands.DescribeInstanceStatus where++import Aws.Ec2.TH++data DescribeInstanceStatus = DescribeInstanceStatus { dis_instanceIds :: [Text] }+ deriving (Show)++ec2ValueTransactionDef ''DescribeInstanceStatus 'DescribeInstanceStatus "instanceStatusSet" "InstanceId"
+ src/Aws/Ec2/Commands/DescribeInstances.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ , RecordWildCards+ #-}++module Aws.Ec2.Commands.DescribeInstances where++import Aws.Ec2.TH++data DescribeInstances = DescribeInstances { di_instanceIds :: [Text] }+ deriving (Show)++instance SignQuery DescribeInstances where+ type ServiceConfiguration DescribeInstances = EC2Configuration+ signQuery DescribeInstances{..} = ec2SignQuery $+ [ ("Action", qArg "DescribeInstances")+ , defVersion+ ] +++ enumerate "InstanceId" di_instanceIds qArg++ec2ValueTransaction ''DescribeInstances "reservationSet"+
+ src/Aws/Ec2/Commands/DescribeKeyPairs.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ #-}++module Aws.Ec2.Commands.DescribeKeyPairs where++import Aws.Ec2.TH++data DescribeKeyPairs = DescribeKeyPairs [Text]+ deriving (Show)++ec2ValueTransactionDef ''DescribeKeyPairs 'DescribeKeyPairs "keySet" "KeyName"
+ src/Aws/Ec2/Commands/DescribeRegions.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ #-}++module Aws.Ec2.Commands.DescribeRegions where++import Aws.Ec2.TH++data DescribeRegions = DescribeRegions [Text]+ deriving (Show)++ec2ValueTransactionDef ''DescribeRegions 'DescribeRegions "regionInfo" "RegionName"
+ src/Aws/Ec2/Commands/DescribeRouteTables.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , TemplateHaskell+ , RecordWildCards+ #-}++-- | Optimized to lookup a default route table for VPC.++module Aws.Ec2.Commands.DescribeRouteTables where++import Aws.Ec2.TH++data DescribeRouteTables = DescribeRouteTables { drt_vpcId :: Text }+ deriving (Show)++instance SignQuery DescribeRouteTables where+ type ServiceConfiguration DescribeRouteTables = EC2Configuration+ signQuery DescribeRouteTables{..} = ec2SignQuery $+ [ ("Action", qArg "DescribeRouteTables")+ , defVersion+ , ("Filter.1.Name", qArg "vpc-id")+ , ("Filter.1.Value.1", qArg drt_vpcId)+ ]++ec2ValueTransaction ''DescribeRouteTables "routeTableSet"
+ src/Aws/Ec2/Commands/DescribeSecurityGroups.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ , RecordWildCards+ #-}++module Aws.Ec2.Commands.DescribeSecurityGroups where++import Aws.Ec2.TH++type SecurityGroupId = Text+type SecurityGroupName = Text++data DescribeSecurityGroups = DescribeSecurityGroups+ { sg_ids :: [SecurityGroupId]+ , sg_names :: [SecurityGroupName]+ }+ deriving (Show)++instance SignQuery DescribeSecurityGroups where+ type ServiceConfiguration DescribeSecurityGroups = EC2Configuration+ signQuery DescribeSecurityGroups{..} = ec2SignQuery $+ [ ("Action", qArg "DescribeSecurityGroups")+ , defVersion+ ] +++ enumerate "GroupId" sg_ids qArg+ +++ case sg_names of+ [] -> []+ _ -> ("Filter.1.Name", qArg "group-name"):(enumerate "Filter.1.Value" sg_names qArg)++ec2ValueTransaction ''DescribeSecurityGroups "securityGroupInfo"
+ src/Aws/Ec2/Commands/DescribeSubnets.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ #-}++module Aws.Ec2.Commands.DescribeSubnets where++import Aws.Ec2.TH++data DescribeSubnets = DescribeSubnets [Text]+ deriving (Show)++ec2ValueTransactionDef ''DescribeSubnets 'DescribeSubnets "subnetSet" "SubnetId"
+ src/Aws/Ec2/Commands/DescribeTags.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ #-}++module Aws.Ec2.Commands.DescribeTags where++import Aws.Ec2.TH++data DescribeTags = DescribeTags [Text]+ deriving (Show)++ec2ValueTransactionDef ''DescribeTags 'DescribeTags "tagSet" "" -- search not implemented
+ src/Aws/Ec2/Commands/DescribeVolumeStatus.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ #-}++module Aws.Ec2.Commands.DescribeVolumeStatus where++import Aws.Ec2.TH++data DescribeVolumeStatus = DescribeVolumeStatus [Text]+ deriving (Show)++ec2ValueTransactionDef ''DescribeVolumeStatus 'DescribeVolumeStatus "volumeStatusSet" "VolumeId"
+ src/Aws/Ec2/Commands/DescribeVolumes.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ #-}++module Aws.Ec2.Commands.DescribeVolumes where++import Aws.Ec2.TH++data DescribeVolumes = DescribeVolumes [Text]+ deriving (Show)++ec2ValueTransactionDef ''DescribeVolumes 'DescribeVolumes "volumeSet" "VolumeId"
+ src/Aws/Ec2/Commands/DescribeVpcs.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.DescribeVpcs where++import Aws.Ec2.TH++data DescribeVpcs = DescribeVpcs { dvpc_vpcIds :: [Text] }+ deriving (Show)++ec2ValueTransactionDef ''DescribeVpcs 'DescribeVpcs "vpcSet" "VpcId"
+ src/Aws/Ec2/Commands/GetConsoleOutput.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell+ , MultiParamTypeClasses+ , TypeFamilies+ , RecordWildCards+ , DeriveGeneric+ #-}++module Aws.Ec2.Commands.GetConsoleOutput where++import Aws.Ec2.TH+import GHC.Generics++data GetConsoleOutput = GetConsoleOutput { gco_instanceId :: Text }+ deriving (Show)++data ConsoleOutput = ConsoleOutput+ { requestId :: Text+ , instanceId :: Text+ , timestamp :: UTCTime+ , output :: Text+ } deriving (Generic, Show)++instance FromJSON ConsoleOutput++instance SignQuery GetConsoleOutput where+ type ServiceConfiguration GetConsoleOutput = EC2Configuration+ signQuery GetConsoleOutput{..} = ec2SignQuery [ ("Action", qArg "GetConsoleOutput")+ , defVersion+ , ("InstanceId", qArg gco_instanceId)+ ]++ec2ValueTransaction ''GetConsoleOutput "GetConsoleOutputResponse"
+ src/Aws/Ec2/Commands/ImportKeyPair.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.ImportKeyPair where++import Data.Text (Text)+import Aws.Ec2.TH++data ImportKeyPair = ImportKeyPair+ { ikp_keyName :: Text+ , ikp_publicKeyMaterial :: Text+ } deriving (Show)++instance SignQuery ImportKeyPair where+ type ServiceConfiguration ImportKeyPair = EC2Configuration+ signQuery ImportKeyPair{..} = ec2SignQuery $ + [ ("Action", qArg "ImportKeyPair")+ , defVersion+ , ("KeyName", qArg ikp_keyName)+ , ("PublicKeyMaterial", qArg ikp_publicKeyMaterial)+ ]++ec2ValueTransaction ''ImportKeyPair "ImportKeyPairResponse"
+ src/Aws/Ec2/Commands/ModifyVpcAttribute.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ #-}++module Aws.Ec2.Commands.ModifyVpcAttribute where++import Aws.Ec2.TH++data VpcAttribute = EnableDnsSupport Bool | EnableDnsHostnames Bool+ deriving (Show)++data ModifyVpcAttribute = ModifyVpcAttribute+ { mva_vpcId :: Text+ , mva_attribute :: VpcAttribute+ } deriving (Show)++instance SignQuery ModifyVpcAttribute where+ type ServiceConfiguration ModifyVpcAttribute = EC2Configuration+ signQuery ModifyVpcAttribute{..} = ec2SignQuery $+ [ ("VpcId", qArg mva_vpcId)+ , ("Action", qArg "ModifyVpcAttribute")+ , defVersion+ ] +++ case mva_attribute of+ EnableDnsSupport es -> [("EnableDnsSupport.Value", qShow es)]+ EnableDnsHostnames eh -> [("EnableDnsHostnames.Value", qShow eh)]++ec2ValueTransaction ''ModifyVpcAttribute "return"
+ src/Aws/Ec2/Commands/RunInstances.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TemplateHaskell+ , LambdaCase+ #-}++module Aws.Ec2.Commands.RunInstances where++import Control.Applicative ((<$>))+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Data.ByteString.Char8 (pack, ByteString)+import qualified Data.ByteString.Base64 as Base64+import qualified Network.HTTP.Types as HTTP+import Data.Monoid+import Aws.Ec2.TH++-- http://docs.aws.amazon.com/AWSEC2/latest/APIReference/ApiReference-query-RunInstances.html+data RunInstances = RunInstances+ { run_imageId :: Text+ , run_count :: (Int, Int)+ , run_instanceType :: Text+ , run_securityGroupIds :: [Text]+ , run_blockDeviceMappings :: [BlockDeviceMapping]+ , run_subnetId :: Maybe Text+ , run_monitoringEnabled :: Bool+ , run_disableApiTermination :: Bool+ , run_instanceInitiatedShutdownBehavior :: InstanceInitiatedShutdownBehavior+ , run_ebsOptimized :: Bool++ , run_keyName :: Maybe Text+ , run_userData :: Maybe Text+ , run_kernelId :: Maybe Text+ , run_ramdiskId :: Maybe Text+ , run_clientToken :: Maybe Text+ , run_iamInstanceProfileARN :: Maybe Text+ , run_availabilityZone :: Maybe Text+ -- , run_placement :: Maybe Placement+ -- also missing: NetworkInterface+ } deriving (Show)++data InstanceInitiatedShutdownBehavior = Stop | Terminate++instance Show InstanceInitiatedShutdownBehavior where+ show Stop = "stop"+ show Terminate = "terminate"++enumerateBlockDevices :: [BlockDeviceMapping] -> HTTP.Query+enumerateBlockDevices = enumerateLists "BlockDeviceMapping." . fmap unroll+ where+ unroll BlockDeviceMapping{..} = [ ("DeviceName", qArg bdm_deviceName)+ ] +++ case bdm_device of+ Ephemeral{..} -> [("VirtualName", qArg bdm_virtualName)]+ EBS ebs -> queryEbsBlockDevice ebs ++instance SignQuery RunInstances where+ type ServiceConfiguration RunInstances = EC2Configuration+ signQuery RunInstances{..} = ec2SignQuery $+ main+ +++ (optionalA "KeyName" run_keyName)+ +++ (optionalA "UserData" (decodeUtf8 . Base64.encode . encodeUtf8 <$> run_userData))+ +++ (optionalA "KernelId" run_kernelId)+ +++ (optionalA "RamdiskId" run_ramdiskId)+ +++ (optionalA "ClientToken" run_clientToken)+ +++ (optionalA "Placement.AvailabilityZone" run_availabilityZone)+ +++ enumerateBlockDevices run_blockDeviceMappings+ where+ main :: HTTP.Query+ main = [ ("Action", qArg "RunInstances")+ , defVersion+ , ("ImageId", qArg run_imageId)+ , ("MinCount", qShow $ fst run_count)+ , ("MaxCount", qShow $ snd run_count)+ , ("InstanceType", qArg run_instanceType)+ , ("Monitoring.Enabled", qShow run_monitoringEnabled)+ , ("DisableApiTermination", qShow run_disableApiTermination)+ , ("InstanceInitiatedShutdownBehavior", qShow run_instanceInitiatedShutdownBehavior)+ , ("EbsOptimized", qShow run_ebsOptimized)+ ] +++ optionalA "IamInstanceProfile.Arn" run_iamInstanceProfileARN+ +++ case run_subnetId of+ Nothing -> enumerate "SecurityGroupId" run_securityGroupIds qArg+ Just subnetId -> [ ("NetworkInterface.0.DeviceIndex", qShow 0)+ , ("NetworkInterface.0.SubnetId", qArg subnetId)+ , ("NetworkInterface.0.AssociatePublicIpAddress", qShow True)+ ] +++ enumerate "NetworkInterface.0.SecurityGroupId" run_securityGroupIds qArg++ec2ValueTransaction ''RunInstances "RunInstancesResponse"+
+ src/Aws/Ec2/Core.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings+ , FlexibleInstances+ , DeriveDataTypeable+ , RecordWildCards+ #-}++module Aws.Ec2.Core (+ EC2Configuration+, EC2Metadata+, ec2SignQuery+, ec2ResponseConsumer+, valueConsumer+, defVersion+) where++import qualified Data.ByteString as B++import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types as HTTP++import Aws.Core+import Aws.Query++type EC2Metadata = QueryMetadata+type EC2Configuration = QueryAPIConfiguration++defVersion :: HTTP.QueryItem+defVersion = ("Version", Just "2014-06-15")++ec2SignQuery :: HTTP.Query -> QueryAPIConfiguration qt -> SignatureData -> SignedQuery+ec2SignQuery query QueryAPIConfiguration{..} sd = querySignQuery query qd sd+ where+ qd = QueryData { qdRegion = qaRegion+ , qdEndpoint = B.concat ["ec2.", qaRegion, ".amazonaws.com"]+ , qdService = "ec2"+ }++ec2ResponseConsumer = queryResponseConsumer
+ src/Aws/Ec2/TH.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ #-}++module Aws.Ec2.TH (+ module Aws.Core+, module Aws.Query+, module Aws.Ec2.Core+, module Aws.Ec2.Types+, Text+, UTCTime+, FromJSON+, ec2ValueTransactionDef+, ec2ValueTransaction+) where++import Data.Text (Text)+import Data.Aeson.Types (FromJSON(..))+import Data.Time.Clock (UTCTime)++import Aws.Core+import Aws.Ec2.Core+import Aws.Ec2.Types+import Aws.Query+import Aws.Query.TH++ec2ValueTransactionDef ty cons tag filterKey = queryValueTransactionDef ty cons tag 'ec2SignQuery 'defVersion "item" filterKey++ec2ValueTransaction = queryValueTransaction
+ src/Aws/Ec2/Types.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE MultiParamTypeClasses+ , FlexibleInstances+ , RecordWildCards+ , LambdaCase+ #-}++module Aws.Ec2.Types where++import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Data.Monoid+import Data.ByteString.Char8 (ByteString, pack)++import Network.HTTP.Types as HTTP++import Aws.Query+import Aws.Ec2.Core++data InstanceTenancy = Default | Dedicated++instance Show InstanceTenancy where+ show Default = "default"+ show Dedicated = "dedicated"++data VolumeType = Standard | GP2SSD | IOPSSD Int++instance Show VolumeType where+ show Standard = "standard"+ show GP2SSD = "gp2"+ show (IOPSSD _) = "io1"++data BlockDeviceMapping = BlockDeviceMapping+ { bdm_deviceName :: Text+ , bdm_device :: BlockDevice+ } deriving (Show)++data BlockDevice = Ephemeral {bdm_virtualName :: Text}+ | EBS EbsBlockDevice+ deriving (Show)++data EbsBlockDevice = EbsBlockDevice+ { ebd_snapshotId :: Maybe Text+ , ebd_deleteOnTermination :: Bool+ , ebd_volumeType :: VolumeType+ , ebd_volumeSize :: Int+ , ebd_encrypted :: Bool+ } deriving (Show)++queryEbsBlockDevice EbsBlockDevice{..} = [ ("VolumeType", qShow ebd_volumeType)+ -- , ("VolumeSize", qShow ebd_volumeSize)+ , ("Size", qShow ebd_volumeSize) -- RunInstances: VolumeSize+ -- , ("DeleteOnTermination", qShow ebd_deleteOnTermination) -- RunInstances only+ , ("Encrypted", qShow ebd_encrypted)+ ] +++ optionalA "SnapshotId" ebd_snapshotId+ +++ case ebd_volumeType of+ IOPSSD iops -> [("Iops", qShow iops)]+ _ -> []+++-- http://docs.aws.amazon.com/AWSEC2/latest/APIReference/ApiReference-query-RunInstances.html+instanceTypes :: [Text]+instanceTypes = [ "t2.micro"+ , "t2.small"+ , "t2.medium"+ , "m3.medium"+ , "m3.large"+ , "m3.xlarge"+ , "m3.2xlarge"+ , "m1.small" -- default+ , "m1.medium"+ , "m1.large"+ , "m1.xlarge"+ , "c3.large"+ , "c3.xlarge"+ , "c3.2xlarge"+ , "c3.4xlarge"+ , "c3.8xlarge"+ , "c1.medium"+ , "c1.xlarge"+ , "cc2.8xlarge"+ , "r3.large"+ , "r3.xlarge"+ , "r3.2xlarge"+ , "r3.4xlarge"+ , "r3.8xlarge"+ , "m2.xlarge"+ , "m2.2xlarge"+ , "m2.4xlarge"+ , "cr1.8xlarge"+ , "i2.xlarge"+ , "i2.2xlarge"+ , "i2.4xlarge"+ , "i2.8xlarge"+ , "hs1.8xlarge"+ , "hi1.4xlarge"+ , "t1.micro"+ , "g2.2xlarge"+ , "cg1.4xlarge"+ ]
+ src/Aws/Elb.hs view
@@ -0,0 +1,27 @@+module Aws.Elb (+ Transaction+, module Aws.Query.Types+, module Aws.Elb.Types+, module Aws.Elb.Core++, module Aws.Elb.Commands.DescribeLoadBalancers+, module Aws.Elb.Commands.CreateLoadBalancer+, module Aws.Elb.Commands.RegisterInstancesWithLoadBalancer+, module Aws.Elb.Commands.DescribeLoadBalancerPolicyTypes+, module Aws.Elb.Commands.DescribeInstanceHealth+, module Aws.Elb.Commands.DescribeLoadBalancerPolicies+, module Aws.Elb.Commands.ModifyLoadBalancerAttributes+) where++import Aws.Core (Transaction)+import Aws.Query.Types+import Aws.Elb.Types+import Aws.Elb.Core++import Aws.Elb.Commands.DescribeLoadBalancers+import Aws.Elb.Commands.CreateLoadBalancer+import Aws.Elb.Commands.RegisterInstancesWithLoadBalancer+import Aws.Elb.Commands.DescribeLoadBalancerPolicyTypes+import Aws.Elb.Commands.DescribeInstanceHealth+import Aws.Elb.Commands.DescribeLoadBalancerPolicies+import Aws.Elb.Commands.ModifyLoadBalancerAttributes
+ src/Aws/Elb/Commands/CreateLoadBalancer.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ , RecordWildCards+ #-}++module Aws.Elb.Commands.CreateLoadBalancer where++import qualified Network.HTTP.Types as HTTP+import Aws.Elb.TH++data LbProtocol = HTTP | HTTPS | TCP | SSL+ deriving (Show)++data Scheme = Internal | Public+ deriving (Show)++data Listener = Listener+ { l_lbPort :: Int+ , l_instancePort :: Int+ , l_instanceProtocol :: LbProtocol+ , l_lbProtocol :: LbProtocol+ , l_sslCertificateId :: Maybe Text+ } deriving (Show)++data CreateLoadBalancer = CreateLoadBalancer+ { clb_name :: Text+ , clb_listeners :: [Listener]+ , clb_scheme :: Scheme+ , clb_securityGroupIds :: [Text]+ , clb_subnetIds :: [Text] -- ^ one per AZ+ } deriving (Show)++enumerateListeners :: [Listener] -> HTTP.Query+enumerateListeners = enumerateLists "Listeners.member." . fmap unroll+ where+ unroll Listener{..} = [ ("LoadBalancerPort", qShow l_lbPort)+ , ("InstancePort", qShow l_instancePort)+ , ("InstanceProtocol", qShow l_instanceProtocol)+ , ("Protocol", qShow l_lbProtocol)+ ] +++ optionalA "SSLCertificateId" l_sslCertificateId++instance SignQuery CreateLoadBalancer where+ type ServiceConfiguration CreateLoadBalancer = QueryAPIConfiguration+ signQuery CreateLoadBalancer{..} = elbSignQuery $+ [ ("Action", qArg "CreateLoadBalancer")+ , defVersion+ , ("LoadBalancerName", qArg clb_name)+ ] +++ enumerateListeners clb_listeners+ +++ enumerate "Subnets.member" clb_subnetIds qArg+ +++ enumerate "SecurityGroups.member" clb_securityGroupIds qArg+ +++ case clb_scheme of+ Internal -> [("Scheme", qArg "internal")]+ _ -> []+++elbValueTransaction ''CreateLoadBalancer "CreateLoadBalancerResult"
+ src/Aws/Elb/Commands/DescribeInstanceHealth.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ , RecordWildCards+ #-}++module Aws.Elb.Commands.DescribeInstanceHealth where++import Aws.Elb.TH++data DescribeInstanceHealth = DescribeInstanceHealth Text++instance SignQuery DescribeInstanceHealth where+ type ServiceConfiguration DescribeInstanceHealth = QueryAPIConfiguration+ signQuery (DescribeInstanceHealth lb) = elbSignQuery $ [ ("Action", qArg "DescribeInstanceHealth")+ , defVersion+ , ("LoadBalancerName", qArg lb)+ ]++elbValueTransaction ''DescribeInstanceHealth "DescribeInstanceHealthResult"
+ src/Aws/Elb/Commands/DescribeLoadBalancerPolicies.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ , RecordWildCards+ #-}++module Aws.Elb.Commands.DescribeLoadBalancerPolicies where++import Aws.Elb.TH++data DescribeLoadBalancerPolicies = DescribeLoadBalancerPolicies Text++instance SignQuery DescribeLoadBalancerPolicies where+ type ServiceConfiguration DescribeLoadBalancerPolicies = QueryAPIConfiguration+ signQuery (DescribeLoadBalancerPolicies lb) = elbSignQuery $ [ ("Action", qArg "DescribeLoadBalancerPolicies")+ , defVersion+ , ("LoadBalancerName", qArg lb)+ ]++elbValueTransaction ''DescribeLoadBalancerPolicies "DescribeLoadBalancerPoliciesResult"
+ src/Aws/Elb/Commands/DescribeLoadBalancerPolicyTypes.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ , RecordWildCards+ #-}++module Aws.Elb.Commands.DescribeLoadBalancerPolicyTypes where++import qualified Text.XML.Cursor as Cu+import Text.XML.Cursor (($.//), (&|))+import qualified Data.Vector as V++import Aws.Elb.TH++data DescribeLoadBalancerPolicyTypes = ListLoadBalancerPolicyTypes+ | DescribeLoadBalancerPolicyTypes [Text]++instance SignQuery DescribeLoadBalancerPolicyTypes where+ type ServiceConfiguration DescribeLoadBalancerPolicyTypes = QueryAPIConfiguration+ signQuery ListLoadBalancerPolicyTypes = elbSignQuery $ [ ("Action", qArg "DescribeLoadBalancerPolicyTypes")+ , defVersion+ ]+ signQuery (DescribeLoadBalancerPolicyTypes types) = elbSignQuery $ [ ("Action", qArg "DescribeLoadBalancerPolicyTypes")+ , defVersion+ ] +++ enumerate "PolicyTypeNames.member" types qArg++instance ResponseConsumer DescribeLoadBalancerPolicyTypes Value where+ type ResponseMetadata Value = QueryMetadata+ responseConsumer ListLoadBalancerPolicyTypes = queryResponseConsumer $ \cu -> do+ let cu' = cu $.// Cu.laxElement "PolicyTypeName" &| (toValue (XMLValueOptions "item") . Cu.node)+ return $ Array $ V.fromList cu'+ responseConsumer (DescribeLoadBalancerPolicyTypes _) = queryResponseConsumer $ valueConsumerOpt (XMLValueOptions "member") "DescribeLoadBalancerPolicyTypesResult" id++instance Transaction DescribeLoadBalancerPolicyTypes Value
+ src/Aws/Elb/Commands/DescribeLoadBalancers.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ , RecordWildCards+ #-}++module Aws.Elb.Commands.DescribeLoadBalancers where++import Aws.Elb.TH++data DescribeLoadBalancers = DescribeLoadBalancers [Text]++elbValueTransactionDef ''DescribeLoadBalancers 'DescribeLoadBalancers "LoadBalancerDescriptions" "LoadBalancerNames.member"
+ src/Aws/Elb/Commands/ModifyLoadBalancerAttributes.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ , RecordWildCards+ #-}++module Aws.Elb.Commands.ModifyLoadBalancerAttributes where++import Aws.Elb.TH++type S3BucketName = Text+type S3BucketPrefix = Text+data EmitInterval = Min5 | Min60 deriving (Show)++data LoadBalancerAttribute = AccessLog Bool EmitInterval S3BucketName S3BucketPrefix+ | ConnectionDraining Bool Int+ | CrossZoneLoadBalancing Bool+ deriving (Show)++data ModifyLoadBalancerAttributes = ModifyLoadBalancerAttributes+ { mlba_name :: Text+ , mlba_attributes :: [LoadBalancerAttribute]+ } deriving (Show)++attributeQuery (AccessLog False _ _ _)+ = [ ("LoadBalancerAttributes.AccessLog.Enabled", qBool False)+ ]+attributeQuery (AccessLog enabled interval bucket prefix)+ = [ ("LoadBalancerAttributes.AccessLog.Enabled", qBool enabled)+ , ("LoadBalancerAttributes.AccessLog.EmitInterval", int interval)+ , ("LoadBalancerAttributes.AccessLog.S3BucketName", qArg bucket)+ , ("LoadBalancerAttributes.AccessLog.S3BucketPrefix", qArg prefix)+ ] where int Min5 = qShow 5+ int Min60 = qShow 60+attributeQuery (ConnectionDraining False timeout)+ = [ ("LoadBalancerAttributes.ConnectionDraining.Enabled", qBool False)+ ]+attributeQuery (ConnectionDraining enabled timeout)+ = [ ("LoadBalancerAttributes.ConnectionDraining.Enabled", qBool enabled)+ , ("LoadBalancerAttributes.ConnectionDraining.Timeout", qShow timeout)+ ]+attributeQuery (CrossZoneLoadBalancing enabled)+ = [ ("LoadBalancerAttributes.CrossZoneLoadBalancing.Enabled", qBool enabled)+ ]++instance SignQuery ModifyLoadBalancerAttributes where+ type ServiceConfiguration ModifyLoadBalancerAttributes = QueryAPIConfiguration+ signQuery ModifyLoadBalancerAttributes{..} = elbSignQuery $+ [ ("Action", qArg "ModifyLoadBalancerAttributes")+ , defVersion+ , ("LoadBalancerName", qArg mlba_name)+ ] +++ concatMap attributeQuery mlba_attributes++elbValueTransaction ''ModifyLoadBalancerAttributes "ModifyLoadBalancerAttributesResult"
+ src/Aws/Elb/Commands/RegisterInstancesWithLoadBalancer.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ , RecordWildCards+ #-}++module Aws.Elb.Commands.RegisterInstancesWithLoadBalancer where++import qualified Network.HTTP.Types as HTTP+import Aws.Elb.TH++data RegisterInstancesWithLoadBalancer = RegisterInstancesWithLoadBalancer+ { rilb_name :: Text+ , rilb_instanceIds :: [Text]+ } deriving (Show)++enumerateInstanceIds :: [Text] -> HTTP.Query+enumerateInstanceIds = enumerateLists "Instances.member." . fmap unroll+ where+ unroll i = [("InstanceId", qArg i)]++instance SignQuery RegisterInstancesWithLoadBalancer where+ type ServiceConfiguration RegisterInstancesWithLoadBalancer = QueryAPIConfiguration+ signQuery RegisterInstancesWithLoadBalancer{..} = elbSignQuery $+ [ ("Action", qArg "RegisterInstancesWithLoadBalancer")+ , defVersion+ , ("LoadBalancerName", qArg rilb_name)+ ] +++ enumerateInstanceIds rilb_instanceIds++elbValueTransaction ''RegisterInstancesWithLoadBalancer "RegisterInstancesWithLoadBalancerResult"
+ src/Aws/Elb/Core.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings+ , FlexibleInstances+ , DeriveDataTypeable+ , RecordWildCards+ #-}++module Aws.Elb.Core (+ ELBMetadata+, elbSignQuery+, elbResponseConsumer+, valueConsumer+, defVersion+) where++import qualified Data.ByteString as B++import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types as HTTP++import Aws.Core+import Aws.Query++defVersion :: HTTP.QueryItem+defVersion = ("Version", Just "2012-06-01")++elbSignQuery :: HTTP.Query -> QueryAPIConfiguration qt -> SignatureData -> SignedQuery+elbSignQuery query QueryAPIConfiguration{..} sd = querySignQuery query qd sd+ where+ qd = QueryData { qdRegion = qaRegion+ , qdEndpoint = B.concat ["elasticloadbalancing.", qaRegion, ".amazonaws.com"]+ , qdService = "elasticloadbalancing"+ }++type ELBMetadata = QueryMetadata++elbResponseConsumer = queryResponseConsumer
+ src/Aws/Elb/TH.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ #-}++module Aws.Elb.TH (+ module Aws.Core+, module Aws.Elb.Core+, module Aws.Query+, Text+, FromJSON+, elbValueTransaction+, elbValueTransactionDef+) where++import Language.Haskell.TH+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++import Data.Text (Text)+import Data.Aeson.Types (FromJSON(..))++import Aws.Core+import Aws.Query+import Aws.Query.TH+import Aws.Elb.Core++elbValueTransaction :: Name -> String -> DecsQ+elbValueTransaction ty tag = [d|+ instance ResponseConsumer $(conT ty) Value where+ type ResponseMetadata Value = QueryMetadata+ responseConsumer _ = queryResponseConsumer $ valueConsumerOpt (XMLValueOptions "member") $(stringE tag) id++ instance Transaction $(conT ty) Value+ |]++elbValueTransactionDef ty cons tag filterKey = queryValueTransactionDef ty cons tag 'elbSignQuery 'defVersion "member" filterKey
+ src/Aws/Elb/Types.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE MultiParamTypeClasses+ , FlexibleInstances+ , RecordWildCards+ , LambdaCase+ #-}++module Aws.Elb.Types where++import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Data.Monoid+import Data.ByteString.Char8 (ByteString, pack)++import Network.HTTP.Types as HTTP++import Aws.Query+import Aws.Elb.Core
+ src/Aws/Query.hs view
@@ -0,0 +1,245 @@+-- | AWS Query API.+-- See http://docs.aws.amazon.com/AWSEC2/latest/UserGuide/using-query-api.html++{-# LANGUAGE OverloadedStrings+ , RecordWildCards+ , DeriveDataTypeable+ , MultiParamTypeClasses+ , FlexibleInstances+ #-}++module Aws.Query (+ module Aws.Query.Types+, QueryAPIConfiguration(..)+, QueryData(..)+, QueryMetadata(..)+, QueryError(..)+, querySignQuery+, v2SignQuery+, qArg+, qShow+, qBool+, valueConsumer+, valueConsumerOpt+, queryResponseConsumer+, (+++)+, optional+, optionalA+, enumerate+, enumerateLists+) where++import qualified Control.Exception as C+import Control.Monad.Trans.Resource (throwM)+import Control.Monad (mplus)++import qualified Blaze.ByteString.Builder as Blaze+import qualified Blaze.ByteString.Builder.Char8 as Blaze8++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Base16 as Base16+import qualified Data.Text as T+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)++import Data.List+import Data.Monoid+import Data.Maybe+import Data.IORef+import Data.Typeable (Typeable)++import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types as HTTP++import qualified Text.XML.Cursor as Cu+import Text.XML.Cursor (($//), ($.//))++import Crypto.Hash (hash, Digest, SHA256)+import Data.Byteable (toBytes)++import Aws.Core+import Aws.Query.Types++data QueryAPIConfiguration qt = QueryAPIConfiguration+ { qaRegion :: B.ByteString+ } deriving (Show)++instance DefaultServiceConfiguration (QueryAPIConfiguration NormalQuery) where+ defServiceConfig = QueryAPIConfiguration "us-east-1"+ debugServiceConfig = QueryAPIConfiguration "us-east-1"++data QueryData = QueryData+ { qdEndpoint :: B.ByteString+ , qdRegion :: B.ByteString+ , qdService :: B.ByteString -- ^ matters only for v4 signatures+ } deriving (Show)++data QueryError = QueryError+ { queryStatusCode :: HTTP.Status+ , queryErrorCode :: Text+ , queryErrorMessage :: Text+ } deriving (Show, Typeable)++instance C.Exception QueryError++data QueryMetadata = QueryMetadata+ { requestId :: Maybe Text+ } deriving (Show)++instance Loggable QueryMetadata where+ toLogText (QueryMetadata r) = "Query: requestId=" <> fromMaybe "<none>" r++instance Monoid QueryMetadata where+ mempty = QueryMetadata Nothing+ (QueryMetadata r1) `mappend` (QueryMetadata r2) = QueryMetadata (r1 `mplus` r2)++querySignQuery :: HTTP.Query -> QueryData -> SignatureData -> SignedQuery+querySignQuery query QueryData{..} sd+ = SignedQuery {+ sqMethod = Post+ , sqProtocol = HTTPS+ , sqHost = qdEndpoint+ , sqPort = 443+ , sqPath = "/"+ , sqQuery = []+ , sqDate = Just $ signatureTime sd+ , sqAuthorization = Just auth+ , sqContentType = Just contentType+ , sqContentMd5 = Nothing+ , sqAmzHeaders = [("X-Amz-Date", sigTime)]+ , sqOtherHeaders = []+ , sqBody = Just $ HTTP.RequestBodyBS body+ , sqStringToSign = canonicalRequest+ }+ where+ sigTime = fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd++ body = HTTP.renderQuery False query+ contentType = "application/x-www-form-urlencoded"++ bodyHash = Base16.encode $ toBytes (hash body :: Digest SHA256)++ enumHeaders = "content-type;host;x-amz-date"+ canonicalRequest = B.concat [ "POST\n"+ , "/\n"+ , "\n" -- query string+ , "content-type:"+ , contentType+ , "\n"+ , "host:"+ , qdEndpoint+ , "\n"+ , "x-amz-date:"+ , sigTime+ , "\n"+ , "\n" -- end headers+ , enumHeaders+ , "\n"+ , bodyHash+ ]++ auth = authorizationV4 sd HmacSHA256 qdRegion qdService+ enumHeaders+ canonicalRequest++v2SignQuery :: HTTP.Query -> QueryData -> SignatureData -> SignedQuery+v2SignQuery q QueryData{..} SignatureData{..}+ = SignedQuery {+ sqMethod = Post+ , sqProtocol = HTTPS+ , sqHost = qdEndpoint+ , sqPort = 443+ , sqPath = "/"+ , sqQuery = []+ , sqDate = Just signatureTime+ , sqAuthorization = Nothing+ , sqContentType = Just contentType+ , sqContentMd5 = Nothing+ , sqAmzHeaders = []+ , sqOtherHeaders = []+ , sqBody = Just $ HTTP.RequestBodyBS body+ , sqStringToSign = stringToSign+ }+ where+ contentType = "application/x-www-form-urlencoded"+ accessKey = accessKeyID signatureCredentials+ iamTok = maybe [] (\x -> [("SecurityToken", Just x)]) (iamToken signatureCredentials)++ body = HTTP.renderQuery False signedQuery+ sig = signature signatureCredentials HmacSHA256 stringToSign+ signedQuery = ("Signature", Just sig):expandedQuery++ 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+ ["POST", qdEndpoint, "/"]+ ++ [HTTP.renderQueryBuilder False expandedQuery]++ expandedQuery = HTTP.toQuery . sort $ ((iamTok ++ q) ++) [+ ("AWSAccessKeyId" , Just accessKey)+ , ("SignatureMethod" , Just $ amzHash HmacSHA256)+ , ("SignatureVersion", Just "2")+ , timestampHeader+ ]+++qArg :: Text -> Maybe B.ByteString+qArg = Just . encodeUtf8++qShow :: Show a => a -> Maybe B.ByteString+qShow = Just . B8.pack . show++qBool :: Bool -> Maybe B.ByteString+qBool True = Just "true"+qBool False = Just "false"++valueConsumer :: Text -> (Value -> a) -> Cu.Cursor -> Response QueryMetadata a+valueConsumer = valueConsumerOpt (XMLValueOptions "item")++valueConsumerOpt :: XMLValueOptions -> Text -> (Value -> a) -> Cu.Cursor -> Response QueryMetadata a+valueConsumerOpt options tag cons cu = go $ head cu'+ where+ cu' = cu $.// Cu.laxElement tag+ go = return . cons . toValue options . Cu.node ++-- similar: iamResponseConsumer+queryResponseConsumer :: (Cu.Cursor -> Response QueryMetadata a)+ -> IORef QueryMetadata+ -> HTTPResponseConsumer a+queryResponseConsumer inner md resp = xmlCursorConsumer parse md resp+ where+ parse cursor = do+ let rid = listToMaybe $ cursor $// elContent "RequestID"+ tellMetadata $ QueryMetadata 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 $ QueryError (HTTP.responseStatus resp) errCode errMsg++(+++) :: (Monoid a) => a -> a -> a+(+++) = mappend++optional :: ByteString -> Maybe a -> (a -> Maybe ByteString) -> HTTP.Query+optional k (Just x) f = [(k, f x)]+optional k Nothing f = []++optionalA k v = optional k v qArg++enumerate :: String -> [a] -> (a -> Maybe ByteString) -> HTTP.Query+enumerate k xs f = [(B8.pack $ mconcat [k, ".", show n], f x) | (n, x) <- zip ([1..] :: [Int]) xs]++enumerateLists :: ByteString -> [HTTP.Query] -> HTTP.Query+enumerateLists key xs = mconcat [prefix pairs $ mconcat [key, B8.pack $ show n, "."] | (n, pairs) <- zip ([1..] :: [Int]) xs]+ where+ prefix xs p = [(mconcat [p, k], v) | (k, v) <- xs]
+ src/Aws/Query/TH.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverloadedStrings+ , TemplateHaskell+ #-}++-- boilerplate minimization for experimental stuff+-- also a hub for module re-exports for query commands++module Aws.Query.TH (+ module Aws.Core+, module Aws.Query+, Text+, UTCTime+, FromJSON+, queryValueTransactionDef+, queryValueTransaction+) where++import Language.Haskell.TH+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++import Data.Text (Text)+import Data.Aeson.Types (FromJSON(..))+import Data.Time.Clock (UTCTime)++import Aws.Core+import Aws.Query++queryValueTransactionDef :: Name -> Name -> String -> Name -> Name -> String -> String -> DecsQ+queryValueTransactionDef ty cons tag signF version item filterKey = do+ arg <- newName "arg"+ [d|+ instance SignQuery $(conT ty) where+ type ServiceConfiguration $(conT ty) = QueryAPIConfiguration+ signQuery ($(conP cons [varP arg])) = $(varE signF) $ [ ("Action", qArg $(stringE $ nameBase ty))+ , $(varE version)+ ] +++ enumerate $(stringE filterKey) $(varE arg) qArg++ instance ResponseConsumer $(conT ty) Value where+ type ResponseMetadata Value = QueryMetadata+ responseConsumer _ = queryResponseConsumer $ valueConsumerOpt (XMLValueOptions $(stringE item)) $(stringE tag) id++ instance Transaction $(conT ty) Value+ |]++queryValueTransaction :: Name -> String -> DecsQ+queryValueTransaction ty tag = [d|+ instance ResponseConsumer $(conT ty) Value where+ type ResponseMetadata Value = QueryMetadata+ responseConsumer _ = queryResponseConsumer $ valueConsumer $(stringE tag) id++ instance Transaction $(conT ty) Value+ |]
+ src/Aws/Query/Types.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveGeneric+ , LambdaCase+ , RecordWildCards+ , NamedFieldPuns+ , OverloadedStrings+ , MultiWayIf+ , TypeFamilies+ #-}++module Aws.Query.Types (+ Value(..)+, XMLValueOptions(..)+, toValue+, castValue+) where++import Data.Text (Text)+import qualified Data.Text as T++import Data.Aeson+import Data.Aeson.Types (parseMaybe)+import qualified Data.Vector as V+import qualified Data.List as L++import Text.XML (Element(..), Name(..), Node(..))++import Aws.Core (AsMemoryResponse, MemoryResponse(..))++data XMLValueOptions = XMLValueOptions+ { arrayElementTag :: Text+ }++instance AsMemoryResponse Value where+ type MemoryResponse Value = Value+ loadToMemory = return++-- import Debug.Trace (trace)+-- import Text.Show.Pretty (ppShow)+--+-- traceArg a = ppShow a `trace` a+traceArg = id++castValue :: FromJSON a => Value -> Maybe a+castValue v = parseMaybe (const (parseJSON v)) v++toValue :: XMLValueOptions -> Node -> Value+toValue = value++value :: XMLValueOptions -> Node -> Value+value options (NodeElement e@Element{..}) = values options elementNodes+value options (NodeContent c) = String c+value options _ = Null++values options elementNodes = uncurry (elementValues options) $ traceArg $ (elementKind options elementNodes, elementNodes)++data ElementKind = ObjectLike+ | ArrayLike+ | Other+ deriving (Show)++elementKind XMLValueOptions{..} nodes+ | isXMLArray = ArrayLike+ | isObject = ObjectLike+ | otherwise = Other+ where+ filtered = filterNodes nodes+ elems = onlyElements nodes++ isObject = (not $ null elems) && length filtered == length elems+ isXMLArray = [arrayElementTag] == (L.nub $ fmap forceElementName elems)++elementValues :: XMLValueOptions -> ElementKind -> [Node] -> Value+elementValues options ObjectLike ns = object [(forceElementName n, values options $ filterNodes $ elementNodes $ unElement n) | n <- onlyElements ns]+elementValues options ArrayLike ns = array $ innerNodes ns+ where+ innerNodes :: [Node] -> [Value]+ innerNodes nodes = fmap (values options . filterNodes . elementNodes . unElement) $ onlyElements $ filterNodes $ nodes+elementValues options Other ns = arrayOrValue $ fmap (value options) ns+ where+ arrayOrValue (x:[]) = x+ arrayOrValue [] = Null+ arrayOrValue a = array a++forceElementName = nameLocalName . elementName . unElement+unElement (NodeElement e) = e+array = Array . V.fromList++onlyElements :: [Node] -> [Node]+onlyElements = filter $ \case+ NodeElement _ -> True+ _ -> False++filterNodes :: [Node] -> [Node]+filterNodes = filter $ \case+ NodeContent s -> (T.strip s) /= T.empty+ _ -> True
+ src/Aws/TH.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}++module Aws.TH where++import Control.Applicative ((<$>))+import Data.Monoid (mconcat)+import Language.Haskell.TH++derivePatchedShowRead :: Name -> (String -> String) -> Q [Dec]+derivePatchedShowRead name patch = do+ TyConI (DataD _ _ _ cons _) <- reify name+ let names = (\(NormalC name []) -> name) <$> cons+ Just show <- lookupValueName "show"+ showD <- instanceD (cxt []) (appT (conT ''Show) (conT name)) [fun show names]++ Just read <- lookupValueName "readsPrec"+ Just ret <- lookupValueName "return"+ Just err <- lookupValueName "error"+ Just concat <- lookupValueName "mconcat"+ readD <- instanceD (cxt []) (appT (conT ''Read) (conT name)) [funr read (varE ret) (varE err) (varE concat) names]++ return [showD, readD]+ where+ fun show names = funD show $ (\n -> clause [conP n []] (normalB $ litE $ stringL $ patch $ nameBase n) []) <$> names+ funr read ret err concat names =+ funD read $ mconcat [ (\n -> clause [wildP, litP $ stringL $ patch $ nameBase n]+ (normalB $ appE ret $ tupE [conE n, litE (StringL "")]) []+ ) <$> names+ , [let any = mkName "any"+ in clause [wildP, varP any]+ (normalB $ appE err $ appE concat $ listE [ litE (StringL "unknown ")+ , litE (StringL $ nameBase name)+ , litE (StringL ": ")+ , varE any+ ]) []]+ ]++patchPer s = go s False+ where+ go [] started = []+ go ('P':'e':'r':xs) started@False = 'P' : 'e' : 'r' : go xs started+ go ('P':'e':'r':xs) started@True = '/' : go xs started+ go (x:xs) _ = x : go xs True+