diff --git a/AWS/Credential.hs b/AWS/Credential.hs --- a/AWS/Credential.hs +++ b/AWS/Credential.hs @@ -4,6 +4,7 @@ , AccessKey , SecretAccessKey , loadCredential + , loadCredentialFromFile , newCredential ) where @@ -23,12 +24,16 @@ -- | Load credential from \"./aws.config\". loadCredential :: IO Credential -loadCredential = do - str <- BS.readFile "aws.config" - case parse configParser "" str of - Left err -> fail $ show err - Right conf -> return conf +loadCredential = loadCredentialFromFile "aws.config" -- | Create new credential. newCredential :: AccessKey -> SecretAccessKey -> Credential newCredential key secret = Credential key secret + +-- | Load credential from file. +loadCredentialFromFile :: FilePath -> IO Credential +loadCredentialFromFile path = do + str <- BS.readFile path + case parse configParser "" str of + Left err -> fail $ show err + Right conf -> return conf diff --git a/AWS/EC2/Acl.hs b/AWS/EC2/Acl.hs --- a/AWS/EC2/Acl.hs +++ b/AWS/EC2/Acl.hs @@ -16,6 +16,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Convert import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Query @@ -76,10 +77,7 @@ :: (MonadResource m, MonadBaseControl IO m) => Text -- ^ NetworkAclId -> EC2 m Bool -deleteNetworkAcl aclid = - ec2Query "DeleteNetworkAcl" params returnBool - where - params = [ValueParam "NetworkAclId" aclid] +deleteNetworkAcl = ec2Delete "DeleteNetworkAcl" "NetworkAclId" replaceNetworkAclAssociation :: (MonadResource m, MonadBaseControl IO m) diff --git a/AWS/EC2/Address.hs b/AWS/EC2/Address.hs --- a/AWS/EC2/Address.hs +++ b/AWS/EC2/Address.hs @@ -17,6 +17,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Convert import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Query diff --git a/AWS/EC2/Convert.hs b/AWS/EC2/Convert.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Convert.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE RankNTypes, TemplateHaskell #-} + +module AWS.EC2.Convert + where + +import Data.Text (Text) + +import AWS.Util +import AWS.Lib.Convert +import AWS.EC2.Types + +mkConvertFunc "imageState" ''ImageState ["available", "pending", "failed"] + +mkConvertFunc "productCodeType" ''ProductCodeType ["devpay", "marketplace"] + +mkConvertFunc "imageType" ''ImageType ["machine", "kernel", "ramdisk"] + +platform :: Maybe Text -> Platform +platform Nothing = Other +platform (Just t) + | t == "windows" = Windows + | otherwise = Other + +mkConvertFunc "rootDeviceType" ''RootDeviceType ["ebs", "instance-store"] + +volumeType :: Text -> Maybe Int -> VolumeType +volumeType t Nothing | t == "standard" = Standard +volumeType t (Just i) | t == "io1" = IO1 i +volumeType t _ = err "volume type" t + +mkConvertFunc "virtualizationType" ''VirtualizationType ["paravirtual", "hvm"] + +mkConvertFunc "hypervisor" ''Hypervisor ["ovm", "xen"] + +mkConvertFunc "instanceStatusEventCode" + ''InstanceStatusEventCode + ["instance-reboot", "instance-stop", "system-reboot", "instance-retirement"] + +mkConvertFunc "instanceStatusTypeStatus" + ''InstanceStatusTypeStatus + ["ok", "impaired", "insufficient-data", "not-applicable"] + +instanceStateCodes :: [(Int, InstanceState)] +instanceStateCodes = + [ (0, Pending) + , (16, Running) + , (32, ShuttingDown) + , (48, Terminated) + , (64, Stopping) + , (80, Stopped) + ] + +codeToState :: Int -> InstanceState +codeToState code = case lookup code instanceStateCodes of + Nothing -> UnknownState code + Just st -> st + +mkConvertFunc "instanceMonitoringState" ''InstanceMonitoringState ["disabled", "enabled", "pending"] + +mkConvertFunc "architecture" ''Architecture ["i386", "x86_64"] + +addressDomain :: Maybe Text -> AddressDomain +addressDomain Nothing = AddressDomainStandard +addressDomain (Just t) + | t == "standard" = AddressDomainStandard + | t == "vpc" = AddressDomainVPC + | otherwise = err "address domain" t + +ec2Return :: Text -> EC2Return +ec2Return t + | t == "true" = EC2Success + | otherwise = EC2Error t + +mkConvertFunc "snapshotStatus" ''SnapshotStatus ["pending", "completed", "error"] + +mkConvertFunc "volumeStatus" + ''VolumeState + ["creating", "available", "in-use", "deleting", "deleted", "error"] + +mkConvertFunc "attachmentSetItemResponseStatus" + ''AttachmentSetItemResponseStatus + ["attaching", "attached", "detaching", "detached"] + +mkConvertFunc "shutdownBehavior" ''ShutdownBehavior ["stop", "terminate"] + +mkConvertFunc "vpnConnectionState" ''VpnConnectionState ["pending", "available", "deleting", "deleted"] + +mkConvertFunc "vpnTunnelTelemetryStatus" ''VpnTunnelTelemetryStatus ["UP", "DOWN"] + +mkConvertFunc "vpnStaticRouteSource" ''VpnStaticRouteSource ["Static"] + +mkConvertFunc "vpnStaticRouteState" ''VpnStaticRouteState ["pending", "available", "deleting", "deleted"] + +instanceLifecycle :: Maybe Text -> InstanceLifecycle +instanceLifecycle Nothing = LifecycleNone +instanceLifecycle (Just t) + | t == "spot" = LifecycleSpot + | otherwise = err "lifecycle" t + +mkConvertFunc "subnetState" ''SubnetState ["pending", "available"] + +mkConvertFunc "volumeStatusInfoStatus" ''VolumeStatusInfoStatus ["ok", "impaired", "insufficient-data"] + +mkConvertFunc "networkAclRuleAction" ''NetworkAclRuleAction ["allow", "deny"] + +mkConvertFunc "routeState" ''RouteState ["active", "blackhole"] + +mkConvertFunc "routeOrigin" ''RouteOrigin ["CreateRouteTable", "CreateRoute", "EnableVgwRoutePropagation"] + +mkConvertFunc "vpcState'" ''VpcState ["pending", "available"] + +mkConvertFunc "vpnGatewayState'" ''VpnGatewayState ["pending", "available", "deleting", "deleted"] + +mkConvertFunc "attachmentState'" ''AttachmentState ["attaching", "attached", "detaching", "detached"] + +mkConvertFunc "customerGatewayState'" ''CustomerGatewayState ["pending", "available", "deleting", "deleted"] + +mkConvertFunc "internetGatewayAttachmentState'" ''InternetGatewayAttachmentState ["attaching", "attached", "detaching", "detached", "available"] diff --git a/AWS/EC2/Image.hs b/AWS/EC2/Image.hs --- a/AWS/EC2/Image.hs +++ b/AWS/EC2/Image.hs @@ -14,6 +14,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Convert import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Params @@ -112,7 +113,7 @@ , ("KernelId", rirKernelId req) , ("RamdiskId", rirRamdiskId req) , ("RootDeviceName", rirRootDeviceName req) - ] + ] deregisterImage :: (MonadResource m, MonadBaseControl IO m) diff --git a/AWS/EC2/Instance.hs b/AWS/EC2/Instance.hs --- a/AWS/EC2/Instance.hs +++ b/AWS/EC2/Instance.hs @@ -24,6 +24,7 @@ import Data.Maybe (fromJust) import qualified Data.Map as Map +import AWS.EC2.Convert import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Params @@ -121,7 +122,7 @@ <*> element "ebs" ( InstanceEbsBlockDevice <$> getT "volumeId" - <*> getF "status" attachmentStatus + <*> getF "status" attachmentSetItemResponseStatus <*> getF "attachTime" textToTime <*> getF "deleteOnTermination" textToBool ) diff --git a/AWS/EC2/Internal.hs b/AWS/EC2/Internal.hs --- a/AWS/EC2/Internal.hs +++ b/AWS/EC2/Internal.hs @@ -13,6 +13,7 @@ import Data.Text (Text) import AWS.Class +import AWS.EC2.Convert import AWS.Credential import AWS.Util import AWS.Lib.Parser @@ -72,204 +73,3 @@ returnBool :: MonadThrow m => GLSink Event m Bool returnBool = getF "return" textToBool - -imageState :: Text -> ImageState -imageState a - | a == "available" = ImageAvailable - | a == "pending" = ImagePending - | a == "failed" = ImageFailed - | otherwise = err "image state" a - -productCodeType :: Text -> ProductCodeType -productCodeType t - | t == "marketplace" = Marketplace - | t == "devpay" = Devpay - | otherwise = err "product code type" t - -imageType :: Text -> ImageType -imageType t - | t == "machine" = Machine - | t == "kernel" = Kernel - | t == "ramdisk" = RamDisk - | otherwise = err "image type" t - -platform :: Maybe Text -> Platform -platform Nothing = Other -platform (Just t) - | t == "windows" = Windows - | otherwise = Other - -rootDeviceType :: Text -> RootDeviceType -rootDeviceType t - | t == "ebs" = EBS - | t == "instance-store" = InstanceStore - | otherwise = err "root device type" t - -volumeType :: Text -> Maybe Int -> VolumeType -volumeType t Nothing | t == "standard" = Standard -volumeType t (Just i) | t == "io1" = IO1 i -volumeType t _ = err "volume type" t - -virtualizationType :: Text -> VirtualizationType -virtualizationType t - | t == "paravirtual" = Paravirtual - | t == "hvm" = HVM - | otherwise = err "virtualization type" t - -hypervisor :: Text -> Hypervisor -hypervisor t - | t == "xen" = Xen - | t == "ovm" = OVM - | otherwise = err "hypervisor" t - -instanceStatusEventCode :: Text -> InstanceStatusEventCode -instanceStatusEventCode t - | t == "instance-reboot" = InstanceReboot - | t == "instance-stop" = InstanceStop - | t == "system-reboot" = SystemReboot - | t == "instance-retirement" = InstanceRetirement - | otherwise = err "InstanceStatusEventCode" t - -instanceStatusTypeStatus :: Text -> InstanceStatusTypeStatus -instanceStatusTypeStatus t - | t == "ok" = InstanceStatusOK - | t == "impaired" = InstanceStatusImpaired - | t == "insufficient-data" = InstanceStatusInsufficientData - | t == "not-applicable" = InstanceStatusNotApplicable - | otherwise = err "instance status detail status" t - -instanceStateCodes :: [(Int, InstanceState)] -instanceStateCodes = - [ (0, Pending) - , (16, Running) - , (32, ShuttingDown) - , (48, Terminated) - , (64, Stopping) - , (80, Stopped) - ] - -codeToState :: Int -> InstanceState -codeToState code = case lookup code instanceStateCodes of - Nothing -> UnknownState code - Just st -> st - -instanceMonitoringState :: Text -> InstanceMonitoringState -instanceMonitoringState t - | t == "disabled" = MonitoringDisabled - | t == "enabled" = MonitoringEnabled - | t == "pending" = MonitoringPending - | otherwise = err "monitoring state" t - -architecture :: Text -> Architecture -architecture t - | t == "i386" = I386 - | t == "x86_64" = X86_64 - | otherwise = err "architecture" t - -addressDomain :: Maybe Text -> AddressDomain -addressDomain Nothing = AddressDomainStandard -addressDomain (Just t) - | t == "standard" = AddressDomainStandard - | t == "vpc" = AddressDomainVPC - | otherwise = err "address domain" t - -ec2Return :: Text -> EC2Return -ec2Return t - | t == "true" = EC2Success - | otherwise = EC2Error t - -snapshotStatus :: Text -> SnapshotStatus -snapshotStatus t - | t == "pending" = SSPending - | t == "completed" = SSCompleted - | t == "error" = SSError - | otherwise = err "snapshot status" t - -volumeStatus :: Text -> VolumeState -volumeStatus t - | t == "creating" = VolCreating - | t == "available" = VolAvailable - | t == "in-use" = VolInUse - | t == "deleting" = VolDeleting - | t == "deleted" = VolDeleted - | t == "error" = VolError - | otherwise = err "volume state" t - -attachmentStatus :: Text -> AttachmentStatus -attachmentStatus t - | t == "attaching" = AttAttaching - | t == "attached" = AttAttached - | t == "detaching" = AttDetaching - | t == "detached" = AttDetached - | otherwise = err "attachment status" t - -shutdownBehavior :: Text -> ShutdownBehavior -shutdownBehavior t - | t == "stop" = SBStop - | t == "terminate" = SBTerminate - | otherwise = err "shutdown behavior" t - -vpnConnectionState :: Text -> VpnConnectionState -vpnConnectionState t - | t == "pending" = VCSPending - | t == "available" = VCSAvailable - | t == "deleting" = VCSDeleting - | t == "deleted" = VCSDeleted - | otherwise = err "vpn connection state" t - -vpnTunnelTelemetryStatus :: Text -> VpnTunnelTelemetryStatus -vpnTunnelTelemetryStatus t - | t == "UP" = VTTSUp - | t == "DOWN" = VTTSDown - | otherwise = err "vpn tunnel telemetry status" t - -vpnStaticRouteSource :: Text -> VpnStaticRouteSource -vpnStaticRouteSource t - | t == "Static" = VSRStatic - | otherwise = err "vpn static route source" t - -vpnStaticRouteState :: Text -> VpnStaticRouteState -vpnStaticRouteState t - | t == "pending" = VSRSPending - | t == "available" = VSRSAvailable - | t == "deleting" = VSRSDeleting - | t == "deleted" = VSRSDeleted - | otherwise = err "vpn static route state" t - -instanceLifecycle :: Maybe Text -> InstanceLifecycle -instanceLifecycle Nothing = LifecycleNone -instanceLifecycle (Just t) - | t == "spot" = LifecycleSpot - | otherwise = err "lifecycle" t - -subnetState :: Text -> SubnetState -subnetState t - | t == "pending" = SubnetPending - | t == "available" = SubnetAvailable - | otherwise = err "subnet state" t - -volumeStatusInfoStatus :: Text -> VolumeStatusInfoStatus -volumeStatusInfoStatus t - | t == "ok" = VSIOK - | t == "impaired" = VSIImpaired - | t == "insufficient-data" = VSIInsufficientData - | otherwise = err "VolumeStatusInfo Status" t - -networkAclRuleAction :: Text -> NetworkAclRuleAction -networkAclRuleAction t - | t == "allow" = NetworkAclRuleActionAllow - | t == "deny" = NetworkAclRuleActionDeny - | otherwise = err "network acl rule action" t - -routeState :: Text -> RouteState -routeState t - | t == "active" = RouteStateActive - | t == "blackhole" = RouteStateBlackhole - | otherwise = err "Route State" t - -routeOrigin :: Text -> RouteOrigin -routeOrigin t - | t == "CreateRouteTable" = RouteOriginCreateRouteTable - | t == "CreateRoute" = RouteOriginCreateRoute - | t == "EnableVgwRoutePropagation" = RouteOriginTableEnableVgwRoutePropagation - | otherwise = err "Route Origin" t diff --git a/AWS/EC2/KeyPair.hs b/AWS/EC2/KeyPair.hs --- a/AWS/EC2/KeyPair.hs +++ b/AWS/EC2/KeyPair.hs @@ -51,9 +51,7 @@ :: (MonadResource m, MonadBaseControl IO m) => Text -- ^ KeyName -> EC2 m Bool -deleteKeyPair name = - ec2Query "DeleteKeyPair" [ValueParam "KeyName" name] - $ getF "return" textToBool +deleteKeyPair = ec2Delete "DeleteKeyPair" "KeyName" importKeyPair :: (MonadResource m, MonadBaseControl IO m) diff --git a/AWS/EC2/Query.hs b/AWS/EC2/Query.hs --- a/AWS/EC2/Query.hs +++ b/AWS/EC2/Query.hs @@ -7,6 +7,7 @@ #ifdef DEBUG , ec2QueryDebug #endif + , ec2Delete , module AWS.Lib.Query ) where @@ -120,3 +121,12 @@ (res, _) <- unwrapResumable response res $$ CB.sinkFile "debug.txt" >>= fail "debug" #endif + +ec2Delete + :: (MonadResource m, MonadBaseControl IO m) + => ByteString -- ^ Name of API + -> Text -- ^ Parameter Name of ID + -> Text -- ^ ID of Target + -> EC2 m Bool +ec2Delete apiName idName targetId = do + ec2Query apiName [ ValueParam idName targetId ] returnBool diff --git a/AWS/EC2/RouteTable.hs b/AWS/EC2/RouteTable.hs --- a/AWS/EC2/RouteTable.hs +++ b/AWS/EC2/RouteTable.hs @@ -15,6 +15,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Convert import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Query @@ -85,9 +86,7 @@ :: (MonadResource m, MonadBaseControl IO m) => Text -- ^ RouteTableId -> EC2 m Bool -deleteRouteTable rtid = - ec2Query "DeleteRouteTable" [ValueParam "RouteTableId" rtid] - $ getF "return" textToBool +deleteRouteTable = ec2Delete "DeleteRouteTable" "RouteTableId" ------------------------------------------------------------ -- associateRouteTable diff --git a/AWS/EC2/Snapshot.hs b/AWS/EC2/Snapshot.hs --- a/AWS/EC2/Snapshot.hs +++ b/AWS/EC2/Snapshot.hs @@ -18,6 +18,7 @@ import AWS.EC2.Query import AWS.Lib.Parser import AWS.Util +import AWS.EC2.Convert describeSnapshots :: (MonadResource m, MonadBaseControl IO m) diff --git a/AWS/EC2/Subnets.hs b/AWS/EC2/Subnets.hs --- a/AWS/EC2/Subnets.hs +++ b/AWS/EC2/Subnets.hs @@ -12,6 +12,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Convert import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Query @@ -72,6 +73,4 @@ :: (MonadResource m, MonadBaseControl IO m) => Text -- ^ SubnetId -> EC2 m Bool -deleteSubnet sid = - ec2Query "DeleteSubnet" [ValueParam "SubnetId" sid] - $ getF "return" textToBool +deleteSubnet = ec2Delete "DeleteSubnet" "SubnetId" diff --git a/AWS/EC2/Types.hs b/AWS/EC2/Types.hs --- a/AWS/EC2/Types.hs +++ b/AWS/EC2/Types.hs @@ -5,7 +5,9 @@ , Architecture(..) , AssociateAddressRequest(..) , Attachment(..) - , AttachmentStatus(..) + , AttachmentState(..) + , AttachmentSetItemResponse(..) + , AttachmentSetItemResponseStatus(..) , AvailabilityZone(..) , AvailabilityZoneMessage , BlockDeviceMapping(..) @@ -13,6 +15,9 @@ , ConsoleOutput(..) , CreateSubnetRequest(..) , CreateVolumeRequest(..) + , CreateVpnGatewayType(..) + , CustomerGateway(..) + , CustomerGatewayState(..) , DisassociateAddressRequest(..) , EbsBlockDevice(..) , EbsSource(..) @@ -95,14 +100,21 @@ , VolumeStatusDetail(..) , VolumeStatusInfo(..) , VolumeStatusInfoStatus(..) + , Vpc(..) + , VpcState(..) , VpnConnection(..) , VpnConnectionOptionsRequest(..) , VpnConnectionState(..) + , VpnGateway(..) + , VpnGatewayState(..) , VpnStaticRoute(..) , VpnStaticRouteSource(..) , VpnStaticRouteState(..) , VpnTunnelTelemetry(..) , VpnTunnelTelemetryStatus(..) + , InternetGateway(..) + , InternetGatewayAttachment(..) + , InternetGatewayAttachmentState(..) ) where import Data.Default (Default(..)) @@ -253,7 +265,7 @@ , instancePlatform :: Maybe Text , instanceMonitoring :: InstanceMonitoringState , subnetId :: Maybe Text - , vpcId :: Maybe Text + , instanceVpcId :: Maybe Text , privateIpAddress :: Maybe Text , ipAddress :: Maybe Text , sourceDestCheck :: Maybe Bool @@ -363,7 +375,7 @@ data InstanceEbsBlockDevice = InstanceEbsBlockDevice { instanceEbsVolumeId :: Text - , instanceEbsState :: AttachmentStatus + , instanceEbsState :: AttachmentSetItemResponseStatus , instanceEbsAttachTime :: UTCTime , instanceEbsDeleteOnTermination :: Bool } @@ -515,7 +527,7 @@ , volAvailabilityZone :: Text , volStatus :: VolumeState , volCreateTime :: UTCTime - , volAttachmentSet :: [Attachment] + , volAttachmentSet :: [AttachmentSetItemResponse] , volTagSet :: [ResourceTag] , volVolumeType :: VolumeType } @@ -530,21 +542,21 @@ | VolError deriving (Show, Eq) -data Attachment = Attachment - { attVolumeId :: Text - , attInstanceId :: Text - , attDevice :: Text - , attStatus :: AttachmentStatus - , attAttachTime :: UTCTime - , attDeleteOnTermination :: Maybe Bool +data AttachmentSetItemResponse = AttachmentSetItemResponse + { asirVolumeId :: Text + , asirInstanceId :: Text + , asirDevice :: Text + , asirStatus :: AttachmentSetItemResponseStatus + , asirAttachTime :: UTCTime + , asirDeleteOnTermination :: Maybe Bool } deriving (Show, Eq) -data AttachmentStatus - = AttAttaching - | AttAttached - | AttDetaching - | AttDetached +data AttachmentSetItemResponseStatus + = AsirAttaching + | AsirAttached + | AsirDetaching + | AsirDetached deriving (Show, Eq) data KeyPair = KeyPair @@ -958,3 +970,86 @@ deriving (Show, Eq) type PropagatingVgw = Text + +data Vpc = Vpc + { vpcId :: Text + , vpcState :: VpcState + , vpcCidrBlock :: Text + , vpcDhcpOptionsId :: Text + , vpcTagSet :: [ResourceTag] + , vpcInstanceTenancy :: Text + } + deriving (Show, Eq) + +data VpcState = VpcStatePending | VpcStateAvailable + deriving (Show, Eq) + +data VpnGateway = VpnGateway + { vpnGatewayId :: Text + , vpnGatewayState :: VpnGatewayState + , vpnGatewayType :: Text + , vpnGatewayAvailabilityZone :: Maybe Text + , vpnGatewayAttachments :: [Attachment] + , vpnGatewayTagSet :: [ResourceTag] + } + deriving (Show, Eq) + +data VpnGatewayState + = VpnGatewayStatePending + | VpnGatewayStateAvailable + | VpnGatewayStateDeleting + | VpnGatewayStateDeleted + deriving (Show, Eq) + +data Attachment = Attachment + { attachmentVpcId :: Text + , attachmentState :: AttachmentState + } + deriving (Show, Eq) + +data AttachmentState + = AttachmentStateAttaching + | AttachmentStateAttached + | AttachmentStateDetaching + | AttachmentStateDetached + deriving (Show, Eq) + +data CreateVpnGatewayType = CreateVpnGatewayTypeIpsec1 + +data CustomerGateway = CustomerGateway + { customerGatewayId :: Text + , customerGatewayState :: CustomerGatewayState + , customerGatewayType :: Text + , customerGatewayIpAddress :: Text + , customerGatewayBgpAsn :: Int + , customerGateway :: [ResourceTag] + } + deriving (Show, Eq) + +data CustomerGatewayState + = CustomerGatewayStatePending + | CustomerGatewayStateAvailable + | CustomerGatewayStateDeleting + | CustomerGatewayStateDeleted + deriving (Show, Eq) + +data InternetGateway = InternetGateway + { internetGatewayInternetGatewayId :: Text + , internetGatewayAttachmentSet :: [InternetGatewayAttachment] + , internetGatewayTagSet :: [ResourceTag] + } + deriving (Show, Eq) + +data InternetGatewayAttachment = InternetGatewayAttachment + { internetGatewayAttachmentVpcId :: Text + , internetGatewayAttachmentState :: InternetGatewayAttachmentState + } + deriving (Show, Eq) + +data InternetGatewayAttachmentState + = InternetGatewayAttachmentStateAttaching + | InternetGatewayAttachmentStateAttached + | InternetGatewayAttachmentStateDetaching + | InternetGatewayAttachmentStateDetached + | InternetGatewayAttachmentStateAvailable + deriving (Show, Eq) diff --git a/AWS/EC2/Util.hs b/AWS/EC2/Util.hs --- a/AWS/EC2/Util.hs +++ b/AWS/EC2/Util.hs @@ -1,10 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} module AWS.EC2.Util - ( asList + ( list , head , each + , eachp , wait + , count ) where import Data.Conduit @@ -17,14 +19,15 @@ import Data.Text (Text) import qualified Data.Text as T import Control.Applicative +import Control.Parallel (par) import AWS.EC2.Internal -asList +list :: Monad m => EC2 m (ResumableSource m a) -> EC2 m [a] -asList src = do +list src = do s <- src lift $ s $$+- CL.consume @@ -42,15 +45,33 @@ -> EC2 m (ResumableSource m a) -> EC2 m () each f res = res >>= lift . each' f + where + each' g rsrc = do + (s', ma) <- rsrc $$++ CL.head + maybe (return ()) (\a -> g a >> each' g s') ma -each' +-- | parallel each +eachp :: Monad m => (a -> m b) - -> ResumableSource m a - -> m () -each' f rsrc = do - (s', ma) <- rsrc $$++ CL.head - maybe (return ()) (\a -> f a >> each' f s') ma + -> EC2 m (ResumableSource m a) + -> EC2 m () +eachp f res = res >>= lift . each' f + where + each' g rsrc = do + (s', ma) <- rsrc $$++ CL.head + maybe (return ()) (\a -> g a `par` each' g s') ma + +-- | Count resources. +count + :: Monad m + => EC2 m (ResumableSource m a) + -> EC2 m Int +count ers = do + s <- ers + lift $ s $$+- c 0 + where + c n = await >>= maybe (return n) (const $ c $ n + 1) -- | Wait for condition. -- diff --git a/AWS/EC2/VPC.hs b/AWS/EC2/VPC.hs --- a/AWS/EC2/VPC.hs +++ b/AWS/EC2/VPC.hs @@ -1,7 +1,21 @@ {-# LANGUAGE FlexibleContexts, RankNTypes #-} module AWS.EC2.VPC - ( describeVpnConnections + ( createVpc + , createVpnGateway + , createCustomerGateway + , createInternetGateway + , deleteVpc + , deleteVpnGateway + , deleteCustomerGateway + , deleteInternetGateway + , describeVpnConnections + , describeVpnGateways + , describeVpcs + , describeCustomerGateway + , describeInternetGateways + , attachInternetGateway + , detachInternetGateway ) where import Data.Text (Text) @@ -11,6 +25,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Convert import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Query @@ -19,6 +34,86 @@ import Debug.Trace +------------------------------------------------------------ +-- attachInternetGateway +------------------------------------------------------------ +attachInternetGateway + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ InternetGatewayId + -> Text -- ^ VpcId + -> EC2 m Bool +attachInternetGateway internetGatewayId vid = + ec2Query "AttachInternetGateway" params $ + getF "return" textToBool + where + params = + [ ValueParam "InternetGatewayId" internetGatewayId + , ValueParam "VpcId" vid ] + +------------------------------------------------------------ +-- detachInternetGateway +------------------------------------------------------------ +detachInternetGateway + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ InternetGatewayId + -> Text -- ^ VpcId + -> EC2 m Bool +detachInternetGateway internetGatewayId vid = + ec2Query "DetachInternetGateway" params $ + getF "return" textToBool + where + params = + [ ValueParam "InternetGatewayId" internetGatewayId + , ValueParam "VpcId" vid ] + +------------------------------------------------------------ +-- deleteInternetGateway +------------------------------------------------------------ +deleteInternetGateway + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ InternetGatewayId + -> EC2 m Bool +deleteInternetGateway = ec2Delete "DeleteInternetGateway" "InternetGatewayId" + +------------------------------------------------------------ +-- createInternetGateway +------------------------------------------------------------ +createInternetGateway + :: (MonadResource m, MonadBaseControl IO m) + => EC2 m InternetGateway +createInternetGateway = + ec2Query "CreateInternetGateway" [] $ + element "internetGateway" internetGatewaySink + +------------------------------------------------------------ +-- describeInternetGateways +------------------------------------------------------------ +describeInternetGateways + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ InternetGatewayIds + -> [Filter] -- ^ Filters + -> EC2 m (ResumableSource m InternetGateway) +describeInternetGateways internetGatewayIds filters = do + ec2QuerySource "DescribeInternetGateways" params $ + itemConduit "internetGatewaySet" internetGatewaySink + where + params = + [ ArrayParams "InternetGatewayId" internetGatewayIds + , FilterParams filters + ] + +internetGatewaySink :: MonadThrow m + => GLSink Event m InternetGateway +internetGatewaySink = InternetGateway + <$> getT "internetGatewayId" + <*> itemsSet "attachmentSet" internetGatewayAttachmentSink + <*> resourceTagSink + +internetGatewayAttachmentSink :: MonadThrow m + => GLSink Event m InternetGatewayAttachment +internetGatewayAttachmentSink = InternetGatewayAttachment + <$> getT "vpcId" + <*> getF "state" internetGatewayAttachmentState' describeVpnConnections :: (MonadBaseControl IO m, MonadResource m) => [Text] -- ^ VpnConnectionIds @@ -62,3 +157,168 @@ <*> getF "source" vpnStaticRouteSource <*> getF "state" vpnStaticRouteState ) + +------------------------------------------------------------ +-- describeVpcs +------------------------------------------------------------ +describeVpcs + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ VpcIds + -> [Filter] -- ^ Filters + -> EC2 m (ResumableSource m Vpc) +describeVpcs vpcIds filters = do + ec2QuerySource "DescribeVpcs" params $ + itemConduit "vpcSet" vpcSink + where + params = + [ ArrayParams "VpcId" vpcIds + , FilterParams filters + ] + +vpcSink :: MonadThrow m + => GLSink Event m Vpc +vpcSink = Vpc + <$> getT "vpcId" + <*> getF "state" vpcState' + <*> getT "cidrBlock" + <*> getT "dhcpOptionsId" + <*> resourceTagSink + <*> getT "instanceTenancy" + +------------------------------------------------------------ +-- createVpc +------------------------------------------------------------ +createVpc + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ CidrBlock + -> Maybe Text -- ^ instanceTenancy + -> EC2 m Vpc +createVpc cidrBlock instanceTenancy = + ec2Query "CreateVpc" params $ + element "vpc" vpcSink + where + params = + [ ValueParam "CidrBlock" cidrBlock + ] ++ maybeParams [ ("instanceTenancy", instanceTenancy) ] + +------------------------------------------------------------ +-- deleteVpc +------------------------------------------------------------ +deleteVpc + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ VpcId + -> EC2 m Bool +deleteVpc = ec2Delete "DeleteVpc" "VpcId" + +------------------------------------------------------------ +-- describeVpnGateways +------------------------------------------------------------ +describeVpnGateways + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ VpnGatewayId + -> [Filter] -- ^ Filters + -> EC2 m (ResumableSource m VpnGateway) +describeVpnGateways ids filters = do + ec2QuerySource "DescribeVpnGateways" params $ + itemConduit "vpnGatewaySet" vpnGatewaySink + where + params = + [ ArrayParams "VpnGatewayId" ids + , FilterParams filters + ] + +vpnGatewaySink :: MonadThrow m + => GLSink Event m VpnGateway +vpnGatewaySink = VpnGateway + <$> getT "vpnGatewayId" + <*> getF "state" vpnGatewayState' + <*> getT "type" + <*> getMT "availabilityZone" + <*> itemsSet "attachments" attachmentSink + <*> resourceTagSink + +attachmentSink :: MonadThrow m + => GLSink Event m Attachment +attachmentSink = Attachment + <$> getT "vpcId" + <*> getF "state" attachmentState' + +------------------------------------------------------------ +-- createVpnGateway +------------------------------------------------------------ +createVpnGateway + :: (MonadResource m, MonadBaseControl IO m) + => CreateVpnGatewayType -- ^ Type. The valid value is CreateVpnGatewayTypeIpsec1 + -> Maybe Text -- ^ AvailabilityZone + -> EC2 m VpnGateway +createVpnGateway _ availabilityZone = do + ec2Query "CreateVpnGateway" params $ + element "vpnGateway" vpnGatewaySink + where + params = + [ ValueParam "Type" "ipsec.1" + ] ++ maybeParams [ ("AvailabilityZone", availabilityZone) ] + +------------------------------------------------------------ +-- deleteVpnGateway +------------------------------------------------------------ +deleteVpnGateway + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ VpnGatewayId + -> EC2 m Bool +deleteVpnGateway = ec2Delete "DeleteVpnGateway" "VpnGatewayId" + +------------------------------------------------------------ +-- describeCustomerGateway +------------------------------------------------------------ +describeCustomerGateway + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ CustomerGatewayId + -> [Filter] -- ^ Filters + -> EC2 m (ResumableSource m CustomerGateway) +describeCustomerGateway ids filters = do + ec2QuerySource "DescribeCustomerGateways" params $ + itemConduit "customerGatewaySet" customerGatewaySink + where + params = + [ ArrayParams "CustomerGatewayId" ids + , FilterParams filters + ] + +customerGatewaySink :: MonadThrow m + => GLSink Event m CustomerGateway +customerGatewaySink = CustomerGateway + <$> getT "customerGatewayId" + <*> getF "state" customerGatewayState' + <*> getT "type" + <*> getT "ipAddress" + <*> getF "bgpAsn" textToInt + <*> resourceTagSink + +------------------------------------------------------------ +-- createCustomerGateway +------------------------------------------------------------ +createCustomerGateway + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ Type + -> Text -- ^ IpAddress + -> Int -- ^ BgpAsn + -> EC2 m CustomerGateway +createCustomerGateway type' ipAddr bgpAsn = do + ec2Query "CreateCustomerGateway" params $ + element "customerGateway" customerGatewaySink + where + params = + [ ValueParam "Type" type' + , ValueParam "IpAddress" ipAddr + , ValueParam "BgpAsn" (toText bgpAsn) + ] + +------------------------------------------------------------ +-- deleteCustomerGateway +------------------------------------------------------------ +deleteCustomerGateway + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ CustomerGatewayId + -> EC2 m Bool +deleteCustomerGateway = ec2Delete "DeleteCustomerGateway" "CustomerGatewayId" diff --git a/AWS/EC2/Volume.hs b/AWS/EC2/Volume.hs --- a/AWS/EC2/Volume.hs +++ b/AWS/EC2/Volume.hs @@ -9,7 +9,7 @@ , enableVolumeIO , describeVolumeAttribute , modifyVolumeAttribute - ) where + ) where import Data.Text (Text) import Data.XML.Types (Event) @@ -17,6 +17,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Convert import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Query @@ -50,12 +51,12 @@ <*> resourceTagSink <*> volumeTypeSink -attachmentSink :: MonadThrow m => GLSink Event m Attachment -attachmentSink = Attachment +attachmentSink :: MonadThrow m => GLSink Event m AttachmentSetItemResponse +attachmentSink = AttachmentSetItemResponse <$> getT "volumeId" <*> getT "instanceId" <*> getT "device" - <*> getF "status" attachmentStatus + <*> getF "status" attachmentSetItemResponseStatus <*> getF "attachTime" textToTime <*> getM "deleteOnTermination" (textToBool <$>) @@ -91,16 +92,14 @@ :: (MonadResource m, MonadBaseControl IO m) => Text -- ^ VolumeId -> EC2 m Bool -deleteVolume volid = - ec2Query "DeleteVolume" [ValueParam "VolumeId" volid] - $ getF "return" textToBool +deleteVolume = ec2Delete "DeleteVolume" "VolumeId" attachVolume :: (MonadResource m, MonadBaseControl IO m) => Text -- ^ VolumeId -> Text -- ^ InstanceId -> Text -- ^ Device - -> EC2 m Attachment + -> EC2 m AttachmentSetItemResponse attachVolume volid iid dev = ec2Query "AttachVolume" params attachmentSink where @@ -116,7 +115,7 @@ -> Maybe Text -- ^ InstanceId -> Maybe Text -- ^ Device -> Maybe Bool -- ^ Force - -> EC2 m Attachment + -> EC2 m AttachmentSetItemResponse detachVolume volid iid dev force = ec2Query "DetachVolume" params attachmentSink where diff --git a/AWS/Lib/Convert.hs b/AWS/Lib/Convert.hs new file mode 100644 --- /dev/null +++ b/AWS/Lib/Convert.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE RankNTypes, OverloadedStrings, TemplateHaskell #-} + +module AWS.Lib.Convert + where + +import Language.Haskell.TH +import Control.Applicative ((<$>)) +import Data.Text (Text) + +import AWS.Util + +mkConvertFunc :: String -> Name -> [String] -> Q [Dec] +mkConvertFunc fs d strs = runQ $ do + v <- newName "v" + ctrs <- (\(TyConI (DataD [] _ [] x [])) -> map (\(NormalC name []) -> name) x) + <$> reify d + return $ + [ SigD (mkName fs) (AppT (AppT ArrowT (ConT ''Text)) (ConT d)) + , FunD (mkName fs) [Clause [VarP v] (NormalB + (CaseE (VarE v) + $ (map (\(s,t) -> Match (LitP (StringL s)) (NormalB (ConE t)) []) $ zip strs ctrs) + ++ [Match WildP (NormalB (AppE (AppE (VarE 'err) (LitE (StringL $ show d))) (LitE (StringL $ show v)))) []]) + ) []] + ] diff --git a/aws-sdk.cabal b/aws-sdk.cabal --- a/aws-sdk.cabal +++ b/aws-sdk.cabal @@ -1,5 +1,5 @@ name: aws-sdk -version: 0.5.0.0 +version: 0.6.0.0 synopsis: AWS SDK for Haskell description: An AWS(Amazon Web Services) liblary for Haskell. license: BSD3 @@ -28,6 +28,7 @@ , AWS.EC2.Internal , AWS.EC2.Address , AWS.EC2.AvailabilityZone + , AWS.EC2.Convert , AWS.EC2.Image , AWS.EC2.Instance , AWS.EC2.Volume @@ -42,6 +43,7 @@ , AWS.EC2.Acl , AWS.EC2.Tag , AWS.EC2.Params + , AWS.Lib.Convert , AWS.Lib.Parser , AWS.Lib.Query , AWS.RDS.Internal @@ -57,7 +59,7 @@ , base64-bytestring >= 1.0.0.0 , bytestring , http-types - , conduit >= 0.5.0 + , conduit >= 0.5.2 , transformers , time , old-locale @@ -74,12 +76,14 @@ , lifted-base , transformers-base , strptime + , template-haskell + , parallel test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: tests - ghc-options: -Wall + ghc-options: -Wall -threaded build-depends: base , hspec