diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,51 @@ +Copyright (c) 2014 Vladimir Kirillov +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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aws-ec2.cabal b/aws-ec2.cabal new file mode 100644 --- /dev/null +++ b/aws-ec2.cabal @@ -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 . + +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 diff --git a/cmd/put-metric.hs b/cmd/put-metric.hs new file mode 100644 --- /dev/null +++ b/cmd/put-metric.hs @@ -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 "") + <*> argument str (metavar "") + <*> argument str (metavar "") + <*> argument auto (metavar "") + <*> argument auto (metavar "") + <*> argument str (metavar "dimension1=value1") + <*> switch (short 'm' <> + long "metadata" <> + help "Use instance metadata to get authentication info") diff --git a/src/Aws/Canonical.hs b/src/Aws/Canonical.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Canonical.hs @@ -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 diff --git a/src/Aws/CloudWatch.hs b/src/Aws/CloudWatch.hs new file mode 100644 --- /dev/null +++ b/src/Aws/CloudWatch.hs @@ -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 diff --git a/src/Aws/CloudWatch/Commands/PutMetricData.hs b/src/Aws/CloudWatch/Commands/PutMetricData.hs new file mode 100644 --- /dev/null +++ b/src/Aws/CloudWatch/Commands/PutMetricData.hs @@ -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" diff --git a/src/Aws/CloudWatch/Core.hs b/src/Aws/CloudWatch/Core.hs new file mode 100644 --- /dev/null +++ b/src/Aws/CloudWatch/Core.hs @@ -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 = "" + } diff --git a/src/Aws/CloudWatch/Types.hs b/src/Aws/CloudWatch/Types.hs new file mode 100644 --- /dev/null +++ b/src/Aws/CloudWatch/Types.hs @@ -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 diff --git a/src/Aws/Ec2.hs b/src/Aws/Ec2.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2.hs @@ -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 diff --git a/src/Aws/Ec2/Commands/AttachInternetGateway.hs b/src/Aws/Ec2/Commands/AttachInternetGateway.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/AttachInternetGateway.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/AttachVolume.hs b/src/Aws/Ec2/Commands/AttachVolume.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/AttachVolume.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/AuthorizeSecurityGroupIngress.hs b/src/Aws/Ec2/Commands/AuthorizeSecurityGroupIngress.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/AuthorizeSecurityGroupIngress.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/CreateInternetGateway.hs b/src/Aws/Ec2/Commands/CreateInternetGateway.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/CreateInternetGateway.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/CreateRoute.hs b/src/Aws/Ec2/Commands/CreateRoute.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/CreateRoute.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/CreateSecurityGroup.hs b/src/Aws/Ec2/Commands/CreateSecurityGroup.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/CreateSecurityGroup.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/CreateSubnet.hs b/src/Aws/Ec2/Commands/CreateSubnet.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/CreateSubnet.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/CreateTags.hs b/src/Aws/Ec2/Commands/CreateTags.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/CreateTags.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/CreateVolume.hs b/src/Aws/Ec2/Commands/CreateVolume.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/CreateVolume.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/CreateVpc.hs b/src/Aws/Ec2/Commands/CreateVpc.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/CreateVpc.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeAvailabilityZones.hs b/src/Aws/Ec2/Commands/DescribeAvailabilityZones.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeAvailabilityZones.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeImages.hs b/src/Aws/Ec2/Commands/DescribeImages.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeImages.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeInstanceStatus.hs b/src/Aws/Ec2/Commands/DescribeInstanceStatus.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeInstanceStatus.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeInstances.hs b/src/Aws/Ec2/Commands/DescribeInstances.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeInstances.hs @@ -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" + diff --git a/src/Aws/Ec2/Commands/DescribeKeyPairs.hs b/src/Aws/Ec2/Commands/DescribeKeyPairs.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeKeyPairs.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeRegions.hs b/src/Aws/Ec2/Commands/DescribeRegions.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeRegions.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeRouteTables.hs b/src/Aws/Ec2/Commands/DescribeRouteTables.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeRouteTables.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeSecurityGroups.hs b/src/Aws/Ec2/Commands/DescribeSecurityGroups.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeSecurityGroups.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeSubnets.hs b/src/Aws/Ec2/Commands/DescribeSubnets.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeSubnets.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeTags.hs b/src/Aws/Ec2/Commands/DescribeTags.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeTags.hs @@ -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 diff --git a/src/Aws/Ec2/Commands/DescribeVolumeStatus.hs b/src/Aws/Ec2/Commands/DescribeVolumeStatus.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeVolumeStatus.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeVolumes.hs b/src/Aws/Ec2/Commands/DescribeVolumes.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeVolumes.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/DescribeVpcs.hs b/src/Aws/Ec2/Commands/DescribeVpcs.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/DescribeVpcs.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/GetConsoleOutput.hs b/src/Aws/Ec2/Commands/GetConsoleOutput.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/GetConsoleOutput.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/ImportKeyPair.hs b/src/Aws/Ec2/Commands/ImportKeyPair.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/ImportKeyPair.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/ModifyVpcAttribute.hs b/src/Aws/Ec2/Commands/ModifyVpcAttribute.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/ModifyVpcAttribute.hs @@ -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" diff --git a/src/Aws/Ec2/Commands/RunInstances.hs b/src/Aws/Ec2/Commands/RunInstances.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Commands/RunInstances.hs @@ -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" + diff --git a/src/Aws/Ec2/Core.hs b/src/Aws/Ec2/Core.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Core.hs @@ -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 diff --git a/src/Aws/Ec2/TH.hs b/src/Aws/Ec2/TH.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/TH.hs @@ -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 diff --git a/src/Aws/Ec2/Types.hs b/src/Aws/Ec2/Types.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Ec2/Types.hs @@ -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" + ] diff --git a/src/Aws/Elb.hs b/src/Aws/Elb.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb.hs @@ -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 diff --git a/src/Aws/Elb/Commands/CreateLoadBalancer.hs b/src/Aws/Elb/Commands/CreateLoadBalancer.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/Commands/CreateLoadBalancer.hs @@ -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" diff --git a/src/Aws/Elb/Commands/DescribeInstanceHealth.hs b/src/Aws/Elb/Commands/DescribeInstanceHealth.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/Commands/DescribeInstanceHealth.hs @@ -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" diff --git a/src/Aws/Elb/Commands/DescribeLoadBalancerPolicies.hs b/src/Aws/Elb/Commands/DescribeLoadBalancerPolicies.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/Commands/DescribeLoadBalancerPolicies.hs @@ -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" diff --git a/src/Aws/Elb/Commands/DescribeLoadBalancerPolicyTypes.hs b/src/Aws/Elb/Commands/DescribeLoadBalancerPolicyTypes.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/Commands/DescribeLoadBalancerPolicyTypes.hs @@ -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 diff --git a/src/Aws/Elb/Commands/DescribeLoadBalancers.hs b/src/Aws/Elb/Commands/DescribeLoadBalancers.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/Commands/DescribeLoadBalancers.hs @@ -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" diff --git a/src/Aws/Elb/Commands/ModifyLoadBalancerAttributes.hs b/src/Aws/Elb/Commands/ModifyLoadBalancerAttributes.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/Commands/ModifyLoadBalancerAttributes.hs @@ -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" diff --git a/src/Aws/Elb/Commands/RegisterInstancesWithLoadBalancer.hs b/src/Aws/Elb/Commands/RegisterInstancesWithLoadBalancer.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/Commands/RegisterInstancesWithLoadBalancer.hs @@ -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" diff --git a/src/Aws/Elb/Core.hs b/src/Aws/Elb/Core.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/Core.hs @@ -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 diff --git a/src/Aws/Elb/TH.hs b/src/Aws/Elb/TH.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/TH.hs @@ -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 diff --git a/src/Aws/Elb/Types.hs b/src/Aws/Elb/Types.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Elb/Types.hs @@ -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 diff --git a/src/Aws/Query.hs b/src/Aws/Query.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Query.hs @@ -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 "" 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] diff --git a/src/Aws/Query/TH.hs b/src/Aws/Query/TH.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Query/TH.hs @@ -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 + |] diff --git a/src/Aws/Query/Types.hs b/src/Aws/Query/Types.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Query/Types.hs @@ -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 diff --git a/src/Aws/TH.hs b/src/Aws/TH.hs new file mode 100644 --- /dev/null +++ b/src/Aws/TH.hs @@ -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 +