diff --git a/AWS/EC2/Internal.hs b/AWS/EC2/Internal.hs --- a/AWS/EC2/Internal.hs +++ b/AWS/EC2/Internal.hs @@ -72,3 +72,172 @@ 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 -> VolumeStatus +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 diff --git a/AWS/EC2/Types.hs b/AWS/EC2/Types.hs --- a/AWS/EC2/Types.hs +++ b/AWS/EC2/Types.hs @@ -1,12 +1,92 @@ -module AWS.EC2.Types where +module AWS.EC2.Types + ( Address(..) + , AddressDomain(..) + , AllocateAddressResponse(..) + , Architecture(..) + , AssociateAddressRequest(..) + , Attachment(..) + , AttachmentStatus(..) + , AvailabilityZone(..) + , AvailabilityZoneMessage + , BlockDeviceMapping(..) + , BlockDeviceMappingParam(..) + , ConsoleOutput(..) + , CreateVolumeRequest(..) + , DisassociateAddressRequest(..) + , EbsBlockDevice(..) + , EbsSource(..) + , EC2Return(..) + , Group(..) + , Hypervisor(..) + , IamInstanceProfile(..) + , Image(..) + , ImageState(..) + , ImageType(..) + , Instance(..) + , InstanceAttribute(..) + , InstanceAttributeRequest(..) + , InstanceBlockDeviceMapping(..) + , InstanceEbsBlockDevice(..) + , InstanceLifecycle(..) + , InstanceMonitoringState(..) + , InstanceNetworkInterface(..) + , InstancePrivateIpAddress(..) + , InstanceState(..) + , InstanceStateChange(..) + , InstanceStatus(..) + , InstanceStatusEvent(..) + , InstanceStatusEventCode(..) + , InstanceStatusType(..) + , InstanceStatusTypeStatus(..) + , InstanceStatusDetail(..) + , InstanceStatusDetailName + , InstanceStatusDetailStatus + , IpPermission(..) + , IpRange(..) + , KeyPair(..) + , ModifyInstanceAttributeRequest(..) + , NetworkInterfaceAssociation(..) + , NetworkInterfaceAttachment(..) + , NetworkInterfaceParam(..) + , PasswordData(..) + , Placement(..) + , Platform(..) + , ProductCode(..) + , ProductCodeType(..) + , Region(..) + , RegisterImageRequest(..) + , Reservation(..) + , ResetInstanceAttributeRequest(..) + , ResourceTag(..) + , RootDeviceType(..) + , RunInstancesRequest(..) + , SecurityGroup(..) + , SecurityGroupRequest(..) + , ShutdownBehavior(..) + , Snapshot(..) + , SnapshotStatus(..) + , StateReason(..) + , Tag(..) + , UserIdGroupPair(..) + , VirtualizationType(..) + , Volume(..) + , VolumeType(..) + , VolumeStatus(..) + , VpnConnection(..) + , VpnConnectionOptionsRequest(..) + , VpnConnectionState(..) + , VpnStaticRoute(..) + , VpnStaticRouteSource(..) + , VpnStaticRouteState(..) + , VpnTunnelTelemetry(..) + , VpnTunnelTelemetryStatus(..) + ) where import Data.Default (Default(..)) import Data.Text (Text) import Data.ByteString (ByteString) import Data.Time (UTCTime) -import AWS.Util - data Image = Image { imageId :: Text , imageLocation :: Text @@ -40,13 +120,6 @@ | ImageFailed deriving (Show, Eq) -imageState :: Text -> ImageState -imageState a - | a == "available" = ImageAvailable - | a == "pending" = ImagePending - | a == "failed" = ImageFailed - | otherwise = err "image state" a - data ProductCode = ProductCode { pcCode :: Text , pcType :: ProductCodeType @@ -57,34 +130,15 @@ | Marketplace deriving (Show, Eq) -productCodeType :: Text -> ProductCodeType -productCodeType t - | t == "marketplace" = Marketplace - | t == "devpay" = Devpay - | otherwise = err "product code type" t - data ImageType = Machine | Kernel | RamDisk deriving (Show, Eq) -imageType :: Text -> ImageType -imageType t - | t == "machine" = Machine - | t == "kernel" = Kernel - | t == "ramdisk" = RamDisk - | otherwise = err "image type" t - data Platform = Windows | Other deriving (Show, Eq) -platform :: Maybe Text -> Platform -platform Nothing = Other -platform (Just t) - | t == "windows" = Windows - | otherwise = Other - data StateReason = StateReason { stateReasonCode :: Text , stateReasonMessage :: Text @@ -96,12 +150,6 @@ | InstanceStore deriving (Show, Eq) -rootDeviceType :: Text -> RootDeviceType -rootDeviceType t - | t == "ebs" = EBS - | t == "instance-store" = InstanceStore - | otherwise = err "root device type" t - data BlockDeviceMapping = BlockDeviceMapping { deviceName :: Text , virtualName :: Maybe Text @@ -121,11 +169,6 @@ | IO1 Int deriving (Show, Eq) -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 - instance Default VolumeType where def = Standard @@ -134,12 +177,6 @@ | HVM deriving (Show, Eq) -virtualizationType :: Text -> VirtualizationType -virtualizationType t - | t == "paravirtual" = Paravirtual - | t == "hvm" = HVM - | otherwise = err "virtualization type" t - data ResourceTag = ResourceTag { resourceKey :: Text , resourceValue :: Maybe Text @@ -150,13 +187,6 @@ | Xen deriving (Show, Eq) -hypervisor :: Text -> Hypervisor -hypervisor t - | t == "xen" = Xen - | t == "ovm" = OVM - | otherwise = err "hypervisor" t - -{- DescribeRegions -} data Region = Region { regionName :: Text , regionEndpoint :: Text @@ -247,14 +277,6 @@ | InstanceRetirement deriving (Show, Eq) -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 - data InstanceStatusType = InstanceStatusType { isdStatus :: InstanceStatusTypeStatus , isdDetails :: [InstanceStatusDetail] @@ -268,14 +290,6 @@ | InstanceStatusNotApplicable deriving (Show, Eq) -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 - data InstanceStatusDetail = InstanceStatusDetail { isddName :: InstanceStatusDetailName , isddStatus :: InstanceStatusDetailStatus @@ -303,21 +317,6 @@ | UnknownState Int deriving (Show, Eq) -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 - data Placement = Placement { placementAvailabilityZone :: Text , placementGroupName :: Text @@ -331,21 +330,8 @@ | MonitoringPending deriving (Show, Eq) -instanceMonitoringState :: Text -> InstanceMonitoringState -instanceMonitoringState t - | t == "disabled" = MonitoringDisabled - | t == "enabled" = MonitoringEnabled - | t == "pending" = MonitoringPending - | otherwise = err "monitoring state" t - data Architecture = I386 | X86_64 deriving (Show, Eq) -architecture :: Text -> Architecture -architecture t - | t == "i386" = I386 - | t == "x86_64" = X86_64 - | otherwise = err "architecture" t - data InstanceBlockDeviceMapping = InstanceBlockDeviceMapping { instanceDeviceName :: Text , instanceEbs :: InstanceEbsBlockDevice @@ -363,12 +349,6 @@ data InstanceLifecycle = LifecycleSpot | LifecycleNone deriving (Show, Eq) -instanceLifecycle :: Maybe Text -> InstanceLifecycle -instanceLifecycle Nothing = LifecycleNone -instanceLifecycle (Just t) - | t == "spot" = LifecycleSpot - | otherwise = err "lifecycle" t - data InstanceNetworkInterface = InstanceNetworkInterface { instanceNetworkInterfaceId :: Text , iniSubnetId :: Text @@ -419,12 +399,6 @@ | SBTerminate deriving (Show, Eq) -shutdownBehavior :: Text -> ShutdownBehavior -shutdownBehavior t - | t == "stop" = SBStop - | t == "terminate" = SBTerminate - | otherwise = err "shutdown behavior" t - data InstanceAttribute = IAInstanceType Text | IAKernelId (Maybe Text) @@ -455,13 +429,6 @@ data AddressDomain = AddressDomainStandard | AddressDomainVPC deriving (Show, Eq) -addressDomain :: Maybe Text -> AddressDomain -addressDomain Nothing = AddressDomainStandard -addressDomain (Just t) - | t == "standard" = AddressDomainStandard - | t == "vpc" = AddressDomainVPC - | otherwise = err "address domain" t - data AllocateAddressResponse = AllocateAddressResponse { alaPublicIp :: Text , alaDomain :: AddressDomain @@ -472,11 +439,6 @@ data EC2Return = EC2Success | EC2Error Text deriving (Show, Eq) -ec2Return :: Text -> EC2Return -ec2Return t - | t == "true" = EC2Success - | otherwise = EC2Error t - data Tag = Tag { tagResourceId :: Text , tagResourceType :: Text @@ -523,13 +485,6 @@ data SnapshotStatus = SSPending | SSCompleted | SSError deriving (Show, Eq) -snapshotStatus :: Text -> SnapshotStatus -snapshotStatus t - | t == "pending" = SSPending - | t == "completed" = SSCompleted - | t == "error" = SSError - | otherwise = err "snapshot status" t - data Volume = Volume { volumeId :: Text , volSize :: Int @@ -552,16 +507,6 @@ | VolError deriving (Show, Eq) -volumeStatus :: Text -> VolumeStatus -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 - data Attachment = Attachment { attVolumeId :: Text , attInstanceId :: Text @@ -579,14 +524,6 @@ | AttDetached deriving (Show, Eq) -attachmentStatus :: Text -> AttachmentStatus -attachmentStatus t - | t == "attaching" = AttAttaching - | t == "attached" = AttAttached - | t == "detaching" = AttDetaching - | t == "detached" = AttDetached - | otherwise = err "attachment status" t - data KeyPair = KeyPair { keyName :: Text , keyFingerprint :: Text @@ -678,14 +615,6 @@ | VCSDeleted deriving (Show, Eq) -vpnConnectionState :: Text -> VpnConnectionState -vpnConnectionState t - | t == "pending" = VCSPending - | t == "available" = VCSAvailable - | t == "deleting" = VCSDeleting - | t == "deleted" = VCSDeleted - | otherwise = err "vpn connection state" t - data VpnTunnelTelemetry = VpnTunnelTelemetry { vttOutsideIpAddress :: Text , vttStatus :: VpnTunnelTelemetryStatus @@ -700,12 +629,6 @@ | VTTSDown deriving (Show, Eq) -vpnTunnelTelemetryStatus :: Text -> VpnTunnelTelemetryStatus -vpnTunnelTelemetryStatus t - | t == "UP" = VTTSUp - | t == "DOWN" = VTTSDown - | otherwise = err "vpn tunnel telemetry status" t - data VpnConnectionOptionsRequest = VpnConnectionOptionsRequest { staticRoutesOnly :: Bool } @@ -721,25 +644,12 @@ data VpnStaticRouteSource = VSRStatic deriving (Show, Eq) -vpnStaticRouteSource :: Text -> VpnStaticRouteSource -vpnStaticRouteSource t - | t == "Static" = VSRStatic - | otherwise = err "vpn static route source" t - data VpnStaticRouteState = VSRSPending | VSRSAvailable | VSRSDeleting | VSRSDeleted deriving (Show, Eq) - -vpnStaticRouteState :: Text -> VpnStaticRouteState -vpnStaticRouteState t - | t == "pending" = VSRSPending - | t == "available" = VSRSAvailable - | t == "deleting" = VSRSDeleting - | t == "deleted" = VSRSDeleted - | otherwise = err "vpn static route state" t data RunInstancesRequest = RunInstancesRequest { riImageId :: Text -- ^ Required diff --git a/AWS/EC2/Util.hs b/AWS/EC2/Util.hs --- a/AWS/EC2/Util.hs +++ b/AWS/EC2/Util.hs @@ -4,12 +4,19 @@ ( asList , head , each + , wait ) where import Data.Conduit import qualified Data.Conduit.List as CL import Control.Monad.Trans.Class (lift) import Prelude hiding (head) +import Safe +import qualified Control.Concurrent as CC +import Control.Monad.IO.Class (liftIO, MonadIO) +import Data.Text (Text) +import qualified Data.Text as T +import Control.Applicative import AWS.EC2.Internal @@ -49,3 +56,31 @@ case ma of Nothing -> return () Just a -> f a >> each' s' f + +-- | Wait for condition. +-- +-- > import AWS.EC2 +-- > import AWS.EC2.Types +-- > import AWS.EC2.Util (asList, wait) +-- > +-- > waitForAvailable :: (MonadIO m, Functor m) +-- > => Text -- ^ ImageId +-- > -> EC2 m a +-- > waitForAvailable = wait +-- > (\img -> imageImageState img == ImageAvailable) +-- > (\imgId -> asList (describeImages [imgId] [] [] [])) +wait + :: (MonadIO m, Functor m) + => (a -> Bool) -- ^ condition + -> (Text -> EC2 m [a]) -- ^ DescribeResources + -> Text -- ^ Resource Id + -> EC2 m a +wait f g rid = do + mr <- headMay <$> g rid + case mr of + Nothing -> fail $ "Resource not found: " ++ T.unpack rid + Just r -> if f r + then return r + else do + liftIO $ CC.threadDelay 5 + wait f g rid 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.4.2.0 +version: 0.4.3.0 synopsis: AWS SDK for Haskell description: An AWS(Amazon Web Services) liblary for Haskell. license: BSD3