aws-sdk 0.1.2.0 → 0.2.0.0

raw patch · 20 files changed

+844/−570 lines, 20 filesdep +strptimePVP ok

version bump matches the API change (PVP)

Dependencies added: strptime

API changes (from Hackage documentation)

Files

• AWS.hs +2/−3
• AWS/EC2.hs +11/−18
• AWS/EC2/Address.hs +20/−2
• AWS/EC2/AvailabilityZone.hs +1/−1
• AWS/EC2/Class.hs +22/−9
• AWS/EC2/Image.hs +3/−4
• AWS/EC2/Instance.hs +180/−29
• AWS/EC2/KeyPair.hs +69/−0
• AWS/EC2/Params.hs +31/−31
• AWS/EC2/Parser.hs +7/−3
• AWS/EC2/Query.hs +60/−11
• AWS/EC2/Region.hs +1/−1
• AWS/EC2/SecurityGroup.hs +171/−0
• AWS/EC2/Snapshot.hs +1/−1
• AWS/EC2/Tag.hs +40/−1
• AWS/EC2/Types.hs +97/−386
• AWS/EC2/Utils.hs +0/−37
• AWS/EC2/Volume.hs +113/−25
• AWS/Util.hs +8/−4
• aws-sdk.cabal +7/−4

@@ -6,7 +6,7 @@ -- > accessKey: your-access-key -- > secretAccessKey: your-secret-access-key ----- The followin is quick example(DescribeInstances).+-- The following is quick example(DescribeInstances). -- -- > module Example where -- > @@ -22,8 +22,7 @@ -- > main = do -- >     cred <- loadCredential -- >     doc <- runResourceT $ do--- >         ctx <- liftIO $ newEC2Context cred--- >         runEC2 ctx $ do+-- >         runEC2 cred $ do -- >             response <- describeInstances [] [] -- >             lift $ response $$ CL.consume -- >     print doc

@@ -5,7 +5,6 @@     ( -- * EC2 Environment       module AWS.EC2.Class     , EC2Endpoint(..)-    , newEC2Context     , setEndpoint       -- * Instances     , module AWS.EC2.Instance@@ -15,19 +14,22 @@     , module AWS.EC2.Volume       -- * Snapshots     , module AWS.EC2.Snapshot+      -- * Addresses+    , module AWS.EC2.Address+      -- * KeyPairs+    , module AWS.EC2.KeyPair+      -- * SecurityGroups+    , module AWS.EC2.SecurityGroup       -- * Placements     , module AWS.EC2.Region     , module AWS.EC2.AvailabilityZone-      -- * Addresses-    , module AWS.EC2.Address       -- * Tags     , module AWS.EC2.Tag     ) where  import Data.Conduit import Control.Monad.Trans.Control (MonadBaseControl)-import qualified Control.Monad.State as ST-import qualified Network.HTTP.Conduit as HTTP+import qualified Control.Monad.State as State  import AWS.Types import AWS.EC2.Class@@ -40,21 +42,12 @@ import AWS.EC2.Tag import AWS.EC2.Snapshot import AWS.EC2.Volume-import AWS.Credential--newEC2Context :: Credential -> IO EC2Context-newEC2Context cred = do-    mgr <- HTTP.newManager HTTP.def-    return EC2Context-        { manager = mgr-        , credential = cred-        , endpoint = UsEast1-        , lastRequestId = Nothing-        }+import AWS.EC2.KeyPair+import AWS.EC2.SecurityGroup  setEndpoint     :: (MonadResource m, MonadBaseControl IO m)     => EC2Endpoint -> EC2 m () setEndpoint ep = do-    ctx <- ST.get-    ST.put ctx { endpoint = ep }+    ctx <- State.get+    State.put ctx { endpoint = ep }

@@ -6,6 +6,8 @@     , releaseAddress     , associateAddress     , AssociateAddressParam(..)+    , disassociateAddress+    , DisassociateAddressParam(..)     ) where  import Data.Text (Text)@@ -39,7 +41,7 @@         ]      addressSet :: MonadThrow m => GLConduit Event m Address-    addressSet = itemConduit "addressesSet" $ address+    addressSet = itemConduit "addressesSet" $ Address         <$> getT "publicIp"         <*> getMT "allocationId"         <*> getM "domain" addressDomain@@ -58,7 +60,7 @@     -> EC2 m AllocateAddressResponse allocateAddress isVpc = do     ec2Query "AllocateAddress" params $-        allocateAddressResponse+        AllocateAddressResponse         <$> getT "publicIp"         <*> getM "domain" addressDomain         <*> getMT "allocationId"@@ -125,3 +127,19 @@         ])   where     f name = maybe [] (\a -> [ValueParam name a])++disassociateAddress+    :: (MonadResource m, MonadBaseControl IO m)+    => DisassociateAddressParam+    -> EC2 m Bool+disassociateAddress param =+    ec2Query "DisassociateAddress" (p param)+        $ getF "return" textToBool+  where+    p (DAEC2 pip) = [ValueParam "PublicIp" pip]+    p (DAVPC aid) = [ValueParam "AssociationId" aid]++data DisassociateAddressParam+    = DAEC2 Text -- ^ PublicIp for EC2+    | DAVPC Text -- ^ AssociationId for VPC+  deriving (Show)

@@ -31,7 +31,7 @@     availabilityZoneInfo :: MonadThrow m         => GLConduit Event m AvailabilityZone     availabilityZoneInfo = itemConduit "availabilityZoneInfo" $-        availabilityZone+        AvailabilityZone         <$> getT "zoneName"         <*> getT "zoneState"         <*> getT "regionName"

@@ -15,10 +15,12 @@  import Control.Monad.State (StateT(..), MonadState) import qualified Control.Monad.State as S+import Control.Monad.Reader (ReaderT(..), MonadReader)+import qualified Control.Monad.Reader as R import Control.Applicative import Control.Monad (liftM) import Control.Monad.Base (MonadBase)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (MonadTrans, lift) import Control.Monad.Trans.Control     ( MonadBaseControl(..)@@ -38,11 +40,17 @@  data EC2Context = EC2Context     { manager :: HTTP.Manager-    , credential :: Credential     , endpoint :: EC2Endpoint     , lastRequestId :: Maybe Text     } +initialEC2Context :: HTTP.Manager -> EC2Context+initialEC2Context mgr = EC2Context+    { manager = mgr+    , endpoint = UsEast1+    , lastRequestId = Nothing+    }+ data ResponseParserException     = NextToken Text   deriving (Show, Typeable)@@ -50,31 +58,36 @@ instance Exception ResponseParserException  newtype EC2 m a = EC2T-    { runEC2T :: StateT EC2Context m a+    { runEC2T :: StateT EC2Context (ReaderT Credential m) a     } deriving     ( Monad     , Applicative     , Functor     , MonadIO     , MonadState EC2Context+    , MonadReader Credential     , MonadBase base     )  instance MonadTrans EC2 where-    lift = EC2T . lift+    lift = EC2T . lift . lift  instance MonadTransControl EC2 where     newtype StT EC2 a = StEC2 { unStEC2 :: (a, EC2Context) }-    liftWith f = EC2T . StateT $ \s ->+    liftWith f = EC2T . StateT $ \s -> ReaderT $ \r ->         liftM (\x -> (x, s))             (f $ \a -> liftM StEC2-                (S.runStateT (runEC2T a) s))-    restoreT = EC2T . StateT . const . liftM unStEC2+                (R.runReaderT (S.runStateT (runEC2T a) s) r))+    restoreT = EC2T . StateT . const . ReaderT . const . liftM unStEC2  instance MonadBaseControl base m => MonadBaseControl base (EC2 m) where     newtype StM (EC2 m) a = StMEC2 { unStMEC2 :: ComposeSt EC2 m a }     liftBaseWith = defaultLiftBaseWith StMEC2     restoreM = defaultRestoreM unStMEC2 -runEC2 :: Monad m => EC2Context -> EC2 m a -> m a-runEC2 ctx app = S.evalStateT (runEC2T app) ctx+runEC2 :: MonadIO m => Credential -> EC2 m a -> m a+runEC2 cred app = do+    mgr <- liftIO $ HTTP.newManager HTTP.def+    R.runReaderT+        (S.evalStateT (runEC2T app) $ initialEC2Context mgr)+        cred

@@ -13,7 +13,6 @@ import Control.Applicative  import AWS.EC2.Types-import AWS.EC2.Utils import AWS.EC2.Params import AWS.EC2.Class import AWS.EC2.Query@@ -40,7 +39,7 @@  imageItem :: MonadThrow m     => GLSink Event m Image-imageItem = image+imageItem = Image     <$> getT "imageId"     <*> getT "imageLocation"     <*> getF "imageState" imageState@@ -59,11 +58,11 @@     <*> getF "rootDeviceType" rootDeviceType     <*> getMT "rootDeviceName"     <*> itemsSet "blockDeviceMapping" (-        blockDeviceMapping+        BlockDeviceMapping         <$> getT "deviceName"         <*> getMT "virtualName"         <*> elementM "ebs" (-            ebsBlockDevice+            EbsBlockDevice             <$> getMT "snapshotId"             <*> getF "volumeSize" textToInt             <*> getF "deleteOnTermination" textToBool

@@ -12,6 +12,12 @@     , getConsoleOutput     , getPasswordData     , describeInstanceStatus+    , describeInstanceAttribute+    , InstanceAttributeRequest(..)+    , resetInstanceAttribute+    , ResetInstanceAttributeParam(..)+    , modifyInstanceAttribute+    , ModifyInstanceAttributeParam(..)     ) where  import Data.Text (Text)@@ -21,10 +27,11 @@ import Data.Conduit import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative+import Data.Maybe (fromJust)+import qualified Data.Map as Map  import AWS.EC2.Types import AWS.EC2.Params-import AWS.EC2.Utils import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser@@ -50,7 +57,7 @@ reservationSink :: MonadThrow m     => GLSink Event m Reservation reservationSink =-    reservation+    Reservation     <$> getT "reservationId"     <*> getT "ownerId"     <*> groupSetSink@@ -58,14 +65,14 @@     <*> getMT "requesterId"  groupSetSink :: MonadThrow m => GLSink Event m [Group]-groupSetSink = itemsSet "groupSet" $ group+groupSetSink = itemsSet "groupSet" $ Group     <$> getT "groupId"     <*> getT "groupName"  instanceSetSink :: MonadThrow m     => GLSink Event m [Instance] instanceSetSink = itemsSet "instancesSet" $-    ec2Instance+    Instance     <$> getT "instanceId"     <*> getT "imageId"     <*> instanceStateSink "instanceState"@@ -78,7 +85,7 @@     <*> getT "instanceType"     <*> getF "launchTime" textToTime     <*> element "placement" (-        placement+        Placement         <$> getT "availabilityZone"         <*> getT "groupName"         <*> getT "tenancy"@@ -97,17 +104,7 @@     <*> getF "architecture" architecture     <*> getF "rootDeviceType" rootDeviceType     <*> getMT "rootDeviceName"-    <*> itemsSet "blockDeviceMapping" (-        instanceBlockDeviceMapping-        <$> getT "deviceName"-        <*> element "ebs" (-            instanceEbsBlockDevice-            <$> getT "volumeId"-            <*> getF "status" attachmentStatus-            <*> getF "attachTime" textToTime-            <*> getF "deleteOnTermination" textToBool-            )-        )+    <*> instanceBlockDeviceMappingsSink     <*> getM "instanceLifecycle" instanceLifecycle     <*> getMT "spotInstanceRequestId"     <*> getF "virtualizationType" virtualizationType@@ -116,12 +113,26 @@     <*> getF "hypervisor" hypervisor     <*> networkInterfaceSink     <*> elementM "iamInstanceProfile" (-        iamInstanceProfile+        IamInstanceProfile         <$> getT "arn"         <*> getT "id"         )     <*> getF "ebsOptimized" textToBool +instanceBlockDeviceMappingsSink :: MonadThrow m+    => GLSink Event m [InstanceBlockDeviceMapping]+instanceBlockDeviceMappingsSink = itemsSet "blockDeviceMapping" (+    InstanceBlockDeviceMapping+    <$> getT "deviceName"+    <*> element "ebs" (+        InstanceEbsBlockDevice+        <$> getT "volumeId"+        <*> getF "status" attachmentStatus+        <*> getF "attachTime" textToTime+        <*> getF "deleteOnTermination" textToBool+        )+    )+ instanceStateSink :: MonadThrow m     => Text -> GLSink Event m InstanceState instanceStateSink label = element label $@@ -132,7 +143,7 @@ networkInterfaceSink :: MonadThrow m     => GLSink Event m [InstanceNetworkInterface] networkInterfaceSink = itemsSet "networkInterfaceSet" $-    instanceNetworkInterface+    InstanceNetworkInterface     <$> getT "networkInterfaceId"     <*> getT "subnetId"     <*> getT "vpcId"@@ -144,7 +155,7 @@     <*> getF "sourceDestCheck" textToBool     <*> groupSetSink     <*> element "attachment" (-        networkInterfaceAttachment+        NetworkInterfaceAttachment         <$> getT "attachmentId"         <*> getF "deviceIndex" textToInt         <*> getT "status"@@ -153,7 +164,7 @@         )     <*> niAssociationSink     <*> itemsSet "privateIpAddressesSet" (-        instancePrivateIpAddress+        InstancePrivateIpAddress         <$> getT "privateIpAddress"         <*> getF "primary" textToBool         <*> niAssociationSink@@ -162,7 +173,7 @@ niAssociationSink :: MonadThrow m     => GLSink Event m (Maybe NetworkInterfaceAssociation) niAssociationSink = elementM "association" $-    networkInterfaceAssociation+    NetworkInterfaceAssociation     <$> getT "publicIp"     <*> getT "ipOwnerId" @@ -190,11 +201,11 @@     => GLConduit Event m InstanceStatus instanceStatusSet = do     itemConduit "instanceStatusSet" $-        instanceStatus+        InstanceStatus         <$> getT "instanceId"         <*> getT "availabilityZone"         <*> itemsSet "eventsSet" (-            instanceStatusEvent+            InstanceStatusEvent             <$> getF "code" instanceStatusEventCode             <*> getT "description"             <*> getM "notBefore" (textToTime <$>)@@ -207,10 +218,10 @@ instanceStatusTypeSink :: MonadThrow m     => Text -> GLSink Event m InstanceStatusType instanceStatusTypeSink name = element name $-    instanceStatusType+    InstanceStatusType     <$> getF "status" instanceStatusTypeStatus     <*> itemsSet "details" (-        instanceStatusDetail+        InstanceStatusDetail         <$> getT "name"         <*> getT "status"         <*> getM "impairedSince" (textToTime <$>)@@ -232,7 +243,7 @@     :: (MonadResource m, MonadBaseControl IO m)     => Conduit Event m InstanceStateChange instanceStateChangeSet = itemConduit "instancesSet" $ do-    instanceStateChange+    InstanceStateChange     <$> getT "instanceId"     <*> instanceStateSink "currentState"     <*> instanceStateSink "previousState"@@ -260,7 +271,7 @@     => [Text] -- ^ InstanceIds     -> EC2 m Bool rebootInstances instanceIds =-    ec2Query "RebootInstances" params $ getF "return" textToBool+    ec2Query "RebootInstances" params returnBool   where     params = [ArrayParams "InstanceId" instanceIds] @@ -395,7 +406,7 @@     -> EC2 m ConsoleOutput getConsoleOutput iid =     ec2Query "GetConsoleOutput" [ValueParam "InstanceId" iid] $-        consoleOutput+        ConsoleOutput         <$> getT "instanceId"         <*> getF "timestamp" textToTime         <*> getT "output"@@ -409,7 +420,147 @@     -> EC2 m PasswordData getPasswordData iid =     ec2Query "GetPasswordData" [ValueParam "InstanceId" iid] $-        passwordData+        PasswordData         <$> getT "instanceId"         <*> getF "timestamp" textToTime         <*> getT "passwordData"++describeInstanceAttribute+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ InstanceId+    -> InstanceAttributeRequest -- ^ Attribute+    -> EC2 m InstanceAttribute+describeInstanceAttribute iid attr =+    ec2Query "DescribeInstanceAttribute" params+        $ getT "instanceId" *> f attr+  where+    str = iar attr+    params =+        [ ValueParam "InstanceId" iid+        , ValueParam "Attribute" str+        ]+    f IARBlockDeviceMapping = instanceBlockDeviceMappingsSink+        >>= return . IABlockDeviceMapping+    f IARProductCodes =+        productCodeSink >>= return . IAProductCodes+    f IARGroupSet =+        (itemsSet str $ getT "groupId") >>= return . IAGroupSet+    f req = valueSink str (fromJust $ Map.lookup req h)+    h = Map.fromList+        [ (IARInstanceType, IAInstanceType . fromJust)+        , (IARKernelId, IAKernelId)+        , (IARRamdiskId, IARamdiskId)+        , (IARUserData, IAUserData)+        , (IARDisableApiTermination,+           IADisableApiTermination . textToBool . fromJust)+        , (IARShutdownBehavior,+           IAShutdownBehavior . shutdownBehavior . fromJust)+        , (IARRootDeviceName, IARootDeviceName)+        , (IARSourceDestCheck,+           IASourceDestCheck . (textToBool <$>))+        , (IAREbsOptimized, IAEbsOptimized . textToBool . fromJust)+        ]+    valueSink name val =+        (element name $ getMT "value") >>= return . val++data InstanceAttributeRequest+    = IARInstanceType+    | IARKernelId+    | IARRamdiskId+    | IARUserData+    | IARDisableApiTermination+    | IARShutdownBehavior+    | IARRootDeviceName+    | IARBlockDeviceMapping+    | IARSourceDestCheck+    | IARGroupSet+    | IARProductCodes+    | IAREbsOptimized+  deriving (Show, Eq, Ord)++iar :: InstanceAttributeRequest -> Text+iar IARInstanceType          = "instanceType"+iar IARKernelId              = "kernel"+iar IARRamdiskId             = "ramdisk"+iar IARUserData              = "userData"+iar IARDisableApiTermination = "disableApiTermination"+iar IARShutdownBehavior      = "instanceInitiatedShutdownBehavior"+iar IARRootDeviceName        = "rootDeviceName"+iar IARBlockDeviceMapping    = "blockDeviceMapping"+iar IARSourceDestCheck       = "sourceDestCheck"+iar IARGroupSet              = "groupSet"+iar IARProductCodes          = "productCodes"+iar IAREbsOptimized          = "ebsOptimized"++data ResetInstanceAttributeParam+    = RIAPKernel+    | RIAPRamdisk+    | RIAPSourceDestCheck++riap :: ResetInstanceAttributeParam -> Text+riap RIAPKernel          = "kernel"+riap RIAPRamdisk         = "ramdisk"+riap RIAPSourceDestCheck = "sourceDestCheck"++resetInstanceAttribute+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ InstanceId+    -> ResetInstanceAttributeParam+    -> EC2 m Bool+resetInstanceAttribute iid attr =+    ec2Query "ResetInstanceAttribute" params returnBool+  where+    params =+        [ ValueParam "InstanceId" iid+        , ValueParam "Attribute" $ riap attr+        ]++-- | not tested+modifyInstanceAttribute+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ InstanceId+    -> [ModifyInstanceAttributeParam]+    -> EC2 m Bool+modifyInstanceAttribute iid attrs =+    ec2Query "ModifyInstanceAttribute" params returnBool+  where+    params = ValueParam "InstanceId" iid:concatMap miap attrs++data ModifyInstanceAttributeParam+    = MIAPInstanceType Text+    | MIAPKernelId Text+    | MIAPRamdiskId Text+    | MIAPUserData Text+    | MIAPDisableApiTermination Bool+    | MIAPShutdownBehavior ShutdownBehavior+    | MIAPRootDeviceName Text+    | MIAPBlockDeviceMapping [BlockDeviceMappingParam]+    | MIAPSourceDestCheck Bool+    | MIAPGroupSet [Text]+    | MIAPEbsOptimized Bool+  deriving (Show)++miap :: ModifyInstanceAttributeParam -> [QueryParam]+miap (MIAPInstanceType a) =+    [ValueParam "InstanceType.Value" a]+miap (MIAPKernelId a) =+    [ValueParam "Kernel.Value"  a]+miap (MIAPRamdiskId a) =+    [ValueParam "Ramdisk.Value" a]+miap (MIAPUserData a) =+    [ValueParam "UserData.Value" a]+miap (MIAPDisableApiTermination a) =+    [ValueParam "DisableApiTermination.Value" $ toText a]+miap (MIAPShutdownBehavior a) =+    [ValueParam "InstanceInitiatedShutdownBehavior.Value"+     $ sbToText a]+miap (MIAPRootDeviceName a) =+    [ValueParam "RootDeviceName" a]+miap (MIAPBlockDeviceMapping a) =+    [blockDeviceMappingParams a]+miap (MIAPSourceDestCheck a) =+    [ValueParam "SourceDestCheck.Value" $ toText a]+miap (MIAPGroupSet a) =+    [ArrayParams "GroupId" a]+miap (MIAPEbsOptimized a) =+    [ValueParam "EbsOptimized" $ toText a]

@@ -0,0 +1,69 @@+{-# LANGUAGE FlexibleContexts #-}++module AWS.EC2.KeyPair+    ( describeKeyPairs+    , createKeyPair+    , deleteKeyPair+    , importKeyPair+    ) where++import Data.Text (Text)++import Data.XML.Types (Event)+import Data.Conduit+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Applicative++import AWS.EC2.Types+import AWS.EC2.Class+import AWS.EC2.Query+import AWS.EC2.Parser+import AWS.Util++describeKeyPairs+    :: (MonadResource m, MonadBaseControl IO m)+    => [Text] -- ^ PublicIps+    -> [Filter] -- ^ Filters+    -> EC2 m (Source m KeyPair)+describeKeyPairs names filters =+    ec2QuerySource "DescribeKeyPairs" params+        $ itemConduit "keySet" keyPairSink+  where+    params =+        [ ArrayParams "KeyName" names+        , FilterParams filters+        ]++keyPairSink :: MonadThrow m => GLSink Event m KeyPair+keyPairSink = KeyPair+    <$> getT "keyName"+    <*> getT "keyFingerprint"++createKeyPair+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ KeyName+    -> EC2 m (KeyPair, Text) -- ^ KeyPair and KeyMaterial+createKeyPair name =+    ec2Query "CreateKeyPair" [ValueParam "KeyName" name]+        $ (,) <$> keyPairSink <*> getT "keyMaterial"++deleteKeyPair+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ KeyName+    -> EC2 m Bool+deleteKeyPair name =+    ec2Query "DeleteKeyPair" [ValueParam "KeyName" name]+        $ getF "return" textToBool++importKeyPair+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ KeyName+    -> Text -- ^ PublicKeyMaterial+    -> EC2 m KeyPair+importKeyPair name material =+    ec2Query "ImportKeyPair" params keyPairSink+  where+    params =+        [ ValueParam "KeyName" name+        , ValueParam "PublicKeyMaterial" material+        ]

@@ -1,38 +1,38 @@ module AWS.EC2.Params where -import Data.Text (Text)+import Control.Applicative+import qualified Data.Text as T +import AWS.EC2.Query (QueryParam(..)) import AWS.EC2.Types--data BlockDeviceMappingParam-    = BlockDeviceMappingParamEBS-        { bdmpEbsDeviceName :: Text-        , bdmpEbsNoDevice :: Maybe Bool-        , bdmpEbsSource :: EbsSource-        , bdmpEbsDeleteOnTermination :: Maybe Bool-        , bdmpEbsVolumeType :: Maybe VolumeType-        }-    | BlockDeviceMappingParamInstanceStore-        { bdmpIsDeviceName :: Text-        , bdmpIsNoDevice :: Maybe Bool-        , bdmpIsVirtualName :: Maybe Text-        }-  deriving (Show)+import AWS.Util -data EbsSource-    = EbsSnapshotId Text-    | EbsVolumeSize Int-  deriving (Show)+blockDeviceMappingParams+    :: [BlockDeviceMappingParam] -> QueryParam+blockDeviceMappingParams =+    StructArrayParams "BlockDeviceMapping" . map kvs+  where+    kvs (BlockDeviceMappingParamEBS name dev src dot vtype) = +        [ ("Ebs.DeviceName", name)+        , ebsSource src+        ] ++ vtparam vtype ++ (uncurry f =<<+            [ ("Ebs.NoDevice", boolToText <$> dev)+            , ("Ebs.DeleteOnTermination", boolToText <$> dot)+            ])+    kvs (BlockDeviceMappingParamInstanceStore name dev vname) =+        [("Ebs.DeviceName", name)] ++ (uncurry f =<<+            [ ("Ebs.NoDevice", boolToText <$> dev)+            , ("Ebs.VirtualName", vname)+            ]) -data ShutdownBehavior = SBStop | SBTerminate deriving (Show)+    ebsSource (EbsSnapshotId sid) = ("Ebs.SnapshotId", sid)+    ebsSource (EbsVolumeSize size) =+        ("Ebs.VolumeSize", T.pack $ show size) -data NetworkInterfaceParam = NetworkInterfaceParam-    { nipInterfaceId :: Maybe Text-    , nipDeviceIndex :: Maybe Text-    , nipSubnetId :: Maybe Text-    , nipDescription :: Maybe Text-    , nipPrivateIpAddresses :: [Text]-    , nipSecurityGroupIds :: [Text]-    , nipDeleteOnTermination :: Maybe Bool-    }-  deriving (Show)+    f n = maybe [] (\a -> [(n, a)])+    vtparam Nothing = []+    vtparam (Just Standard) = [("Ebs.VolumeType", "standard")]+    vtparam (Just (IO1 iops)) =+        [ ("Ebs.VolumeType", "io1")+        , ("Ebs.Iops", T.pack $ show iops)+        ]

@@ -4,6 +4,7 @@     , productCodeSink     , stateReasonSink     , volumeTypeSink+    , returnBool     ) where  import Control.Applicative@@ -17,21 +18,21 @@ resourceTagSink :: MonadThrow m     => GLSink Event m [ResourceTag] resourceTagSink = itemsSet "tagSet" $-    resourceTag+    ResourceTag     <$> getT "key"     <*> getMT "value"  productCodeSink :: MonadThrow m     => GLSink Event m [ProductCode] productCodeSink = itemsSet "productCodes" $-    productCode+    ProductCode     <$> getT "productCode"     <*> getF "type" productCodeType  stateReasonSink :: MonadThrow m     => GLSink Event m (Maybe StateReason) stateReasonSink = elementM "stateReason" $-    stateReason+    StateReason     <$> getT "code"     <*> getT "message" @@ -40,3 +41,6 @@ volumeTypeSink = volumeType     <$> getT "volumeType"     <*> getM "iops" (textToInt <$>)++returnBool :: MonadThrow m => GLSink Event m Bool+returnBool = getF "return" textToBool

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts, RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}  module AWS.EC2.Query     ( ec2Query@@ -6,6 +7,7 @@     , ec2QuerySource'     , ec2Request     , QueryParam(..)+    , EC2ClientException(..)     ) where  import           Data.ByteString (ByteString)@@ -14,7 +16,7 @@ import qualified Data.ByteString.Char8 as BSC  import Data.Monoid-import Data.XML.Types (Event(..))+import Data.XML.Types (Event(..), Name(..)) import Data.Conduit import qualified Data.Conduit.List as CL import Control.Monad.Trans.Control (MonadBaseControl)@@ -27,11 +29,14 @@ import qualified Network.HTTP.Types as H import qualified Data.Digest.Pure.SHA as SHA import qualified Data.ByteString.Base64 as BASE-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (lift)-import qualified Control.Monad.State as ST+import qualified Control.Monad.State as State+import qualified Control.Monad.Reader as Reader import Control.Exception.Lifted as E import Data.Text (Text)+import Data.Typeable (Typeable)+import Control.Applicative  import AWS.EC2.Types import AWS.Types@@ -43,8 +48,18 @@ {- Debug import Debug.Trace import qualified Data.Conduit.Binary as CB+import System.IO (stdout) --} +data EC2ClientException+    = ClientError+        { errorCode :: Text+        , errorMessage :: Text+        , errorRequestId :: Text+        }+  deriving (Show, Typeable)+instance Exception EC2ClientException+ data QueryParam     = ArrayParams Text [Text]     | FilterParams [Filter]@@ -85,6 +100,7 @@ toArrayParams (ArrayParams name params) = Map.fromList      [ (textToBS name <> "." <> bsShow i, textToBS param)     | (i, param) <- zip ([1..]::[Int]) params+     ] toArrayParams (FilterParams kvs) =     Map.fromList . concat . map f1 $ zip ([1..]::[Int]) kvs@@ -128,21 +144,53 @@     await -- EventBeginElement DescribeImagesResponse     tagContentF "requestId" +checkStatus' ::+    H.Status -> H.ResponseHeaders -> Maybe SomeException+checkStatus' = \s@(H.Status sci _) hs ->+    if 200 <= sci && sci < 300 || sci == 400+        then Nothing+        else Just $ toException $ HTTP.StatusCodeException s hs++sinkError :: MonadThrow m => GLSink Event m a+sinkError = do+    await+    etag "Response" $ do+        (c,m) <- etag "Errors" $ etag "Error" $+            (,) <$> tagt "Code" <*> tagt "Message"+        r <- tagt "RequestID"+        lift $ monadThrow $ ClientError c m r+  where+    etag name inner = XmlP.force "error parse error"+        $ XmlP.tagNoAttr (errName name) inner+    tagt name = etag name XmlP.content+    errName n = Name n Nothing Nothing++clientError+    :: (MonadResource m, MonadBaseControl IO m)+    => ResumableSource m ByteString -> m a+clientError rsrc =+    rsrc $$+- XmlP.parseBytes XmlP.def =$ sinkError+ ec2Request     :: (MonadResource m, MonadBaseControl IO m)-    => EC2Context+    => Credential+    -> EC2Context     -> ByteString     -> [QueryParam]     -> m (ResumableSource m ByteString)-ec2Request ctx action params = do+ec2Request cred ctx action params = do     let mgr = manager ctx-    let cred = credential ctx     let ep = endpoint ctx     time <- liftIO getCurrentTime     let url = mkUrl ep cred time action params     request <- liftIO $ HTTP.parseUrl (BSC.unpack url)-    response <- HTTP.http request mgr-    return $ HTTP.responseBody response+    let req = request { HTTP.checkStatus = checkStatus' }+    response <- HTTP.http req mgr+    let body = HTTP.responseBody response+    if (H.statusCode $ HTTP.responseStatus response) == 400+        then clientError body+        else return ()+    return body  ec2Query     :: (MonadResource m, MonadBaseControl IO m)@@ -171,13 +219,14 @@     -> Conduit Event m o     -> EC2 m (Source m o) ec2QuerySource' action params token cond = do-    ctx <- ST.get+    cred <- Reader.ask+    ctx <- State.get     (src1, rid) <- lift $ do-        response <- ec2Request ctx action params'+        response <- ec2Request cred ctx action params'         (res, _) <- unwrapResumable response --        res $$ CB.sinkFile "debug.txt" >>= fail "debug"         res $= XmlP.parseBytes XmlP.def $$+ sinkRequestId-    ST.put ctx{lastRequestId = Just rid}+    State.put ctx{lastRequestId = Just rid}     lift $ do         (src2, _) <- unwrapResumable src1         return $ src2 $= (cond >> nextToken)

@@ -31,6 +31,6 @@     regionInfoConduit :: MonadThrow m         => GLConduit Event m Region     regionInfoConduit = itemConduit "regionInfo" $-        region+        Region         <$> getT "regionName"         <*> getT "regionEndpoint"

@@ -0,0 +1,171 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}++module AWS.EC2.SecurityGroup+    ( describeSecurityGroups+    , createSecurityGroup+    , deleteSecurityGroup+    , SecurityGroupParam(..)+    , authorizeSecurityGroupIngress+    , authorizeSecurityGroupEgress+    , revokeSecurityGroupIngress+    , revokeSecurityGroupEgress+    ) where++import Data.Text (Text)+import Data.ByteString (ByteString)++import Data.XML.Types (Event)+import Data.Conduit+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Applicative+import Data.Monoid++import AWS.EC2.Types+import AWS.EC2.Class+import AWS.EC2.Query+import AWS.EC2.Parser+import AWS.Util++describeSecurityGroups+    :: (MonadResource m, MonadBaseControl IO m)+    => [Text] -- ^ GroupNames+    -> [Text] -- ^ GroupIds+    -> [Filter] -- ^ Filters+    -> EC2 m (Source m SecurityGroup)+describeSecurityGroups names ids filters =+    ec2QuerySource "DescribeSecurityGroups" params+    $ itemConduit "securityGroupInfo" $+        SecurityGroup+        <$> getT "ownerId"+        <*> getT "groupId"+        <*> getT "groupName"+        <*> getT "groupDescription"+        <*> getMT "vpcId"+        <*> ipPermissionsSink "ipPermissions"+        <*> ipPermissionsSink "ipPermissionsEgress"+        <*> resourceTagSink+  where+    params =+        [ ArrayParams "GroupName" names+        , ArrayParams "GroupId" ids+        , FilterParams filters+        ]++ipPermissionsSink :: MonadThrow m+    => Text -> GLSink Event m [IpPermission]+ipPermissionsSink name = itemsSet name $ IpPermission+    <$> getT "ipProtocol" <*> getM "fromPort" (textToInt <$>)+    <*> getM "toPort" (textToInt <$>)+    <*> itemsSet "groups" (+        UserIdGroupPair+        <$> getMT "userId"+        <*> getT "groupId"+        <*> getMT "groupName"+        )+    <*> itemsSet "ipRanges" (IpRange <$> getT "cidrIp")++createSecurityGroup+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ GroupName+    -> Text -- ^ GroupDescription+    -> Maybe Text -- ^ VpcId+    -> EC2 m (Maybe Text) -- ^ GroupId+createSecurityGroup name desc vpc =+    ec2Query "CreateSecurityGroup" params+        $ getT "return" *> getMT "groupId"+  where+    params =+        [ ValueParam "GroupName" name+        , ValueParam "GroupDescription" desc+        ] ++ maybe [] (\a -> [ValueParam "VpcId" a]) vpc++deleteSecurityGroup+    :: (MonadResource m, MonadBaseControl IO m)+    => SecurityGroupParam+    -> EC2 m Bool+deleteSecurityGroup param =+    ec2Query "DeleteSecurityGroup" [p param]+        $ getF "return" textToBool++p :: SecurityGroupParam -> QueryParam+p (GroupId t)   = ValueParam "GroupId" t+p (GroupName t) = ValueParam "GroupName" t++data SecurityGroupParam = GroupId Text | GroupName Text+  deriving (Show)++-- | not tested+authorizeSecurityGroupIngress+    :: (MonadResource m, MonadBaseControl IO m)+    => SecurityGroupParam+    -> [IpPermission]+    -> EC2 m Bool+authorizeSecurityGroupIngress =+    securityGroupQuery "AuthorizeSecurityGroupIngress"++-- | not tested+authorizeSecurityGroupEgress+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ GroupId+    -> [IpPermission]+    -> EC2 m Bool+authorizeSecurityGroupEgress gid =+    securityGroupQuery "AuthorizeSecurityGroupEgress"+        $ GroupId gid++-- | not tested+revokeSecurityGroupIngress+    :: (MonadResource m, MonadBaseControl IO m)+    => SecurityGroupParam+    -> [IpPermission]+    -> EC2 m Bool+revokeSecurityGroupIngress =+    securityGroupQuery "RevokeSecurityGroupIngress"++-- | not tested+revokeSecurityGroupEgress+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ GroupId+    -> [IpPermission]+    -> EC2 m Bool+revokeSecurityGroupEgress gid =+    securityGroupQuery "RevokeSecurityGroupEgress"+        $ GroupId gid++securityGroupQuery+    :: (MonadResource m, MonadBaseControl IO m)+    => ByteString -- ^ Action+    -> SecurityGroupParam+    -> [IpPermission]+    -> EC2 m Bool+securityGroupQuery act param ipps =+    ec2Query act params $ getF "return" textToBool+  where+    params = [p param]+        ++ concatMap (uncurry ipPermissionParam) (zip intstr ipps)++intstr :: [Int]+intstr = [1..]++ipPermissionParam :: Int -> IpPermission -> [QueryParam]+ipPermissionParam num ipp =+    [ValueParam (pre <> ".IpProtocol") $ ippIpProtocol ipp]+    ++ (uncurry (mk pre) =<<+        [ (".FromPort", toText <$> ippFromPort ipp)+        , (".ToPort", toText <$> ippToPort ipp)+        ])+    ++ map (uncurry ipr) (zip intstr $ ippIpRanges ipp)+    ++ concatMap (uncurry grp) (zip intstr $ ippGroups ipp)+  where+    pre = "IpPermissions." <> toText num+    mk h name = maybe [] (\a -> [ValueParam (h <> name) a])+    grph n = pre <> ".Groups." <> toText n+    grp n g = +        [ ValueParam (grph n <> ".GroupId") $ uigpGroupId g+        ] ++ (uncurry (mk (grph n)) =<<+            [ (".UserId", uigpUserId g)+            , (".GroupName", uigpGroupName g)+            ])+    ipr n r = ValueParam+        (pre <> ".IPRanges." <> toText n <> ".CidrIp")+        $ iprCidrIp r

@@ -39,7 +39,7 @@  snapshotSink :: MonadThrow m     => GLSink Event m Snapshot-snapshotSink = snapshot+snapshotSink = Snapshot         <$> getT "snapshotId"         <*> getT "volumeId"         <*> getF "status" snapshotStatus

@@ -2,8 +2,12 @@  module AWS.EC2.Tag     ( describeTags+    , createTags+    , deleteTags     ) where +import Data.Text (Text)+import Data.Monoid import Data.Conduit import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative@@ -12,6 +16,7 @@ import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser+import AWS.Util  describeTags     :: (MonadResource m, MonadBaseControl IO m)@@ -19,10 +24,44 @@     -> EC2 m (Source m Tag) describeTags filters =     ec2QuerySource "DescribeTags" params $ itemConduit "tagSet" $-        tag+        Tag         <$> getT "resourceId"         <*> getT "resourceType"         <*> getT "key"         <*> getMT "value"   where     params = [FilterParams filters]++createTags+    :: (MonadResource m, MonadBaseControl IO m)+    => [Text] -- ^ ResourceId (instance-id, image-id,..)+    -> [(Text, Text)]+    -> EC2 m Bool+createTags rids kvs =+    ec2Query "CreateTags" params returnBool+  where+    params =+        [ ArrayParams "ResourceId" rids ]+        ++ concatMap (uncurry tags) (zip ([1..]::[Int]) kvs)+    tags n (k, v) =+        [ ValueParam ("Tag." <> toText n <> ".Key") k+        , ValueParam ("Tag." <> toText n <> ".Value") v+        ]++deleteTags+    :: (MonadResource m, MonadBaseControl IO m)+    => [Text] -- ^ ResourceId (instance-id, image-id,..)+    -> [ResourceTag]+    -> EC2 m Bool+deleteTags rids tags =+    ec2Query "DeleteTags" params returnBool+  where+    params =+        [ ArrayParams "ResourceId" rids ]+        ++ concatMap (uncurry tagParam) (zip ([1..]::[Int]) tags)+    tagParam n tag =+        [ ValueParam ("Tag." <> toText n <> ".Key")+         $ resourceKey tag ]+        ++ maybe []+            (\a -> [ValueParam ("Tag." <> toText n <> ".Value") a])+            (resourceValue tag)

@@ -33,39 +33,6 @@     }   deriving (Show) -image-    :: Text -> Text -> ImageState -> Text -> Bool-    -> [ProductCode] -> Text -> ImageType -> Maybe Text-    -> Maybe Text -> Platform -> Maybe StateReason-    -> Maybe Text -> Text -> Text -> RootDeviceType-    -> Maybe Text -> [BlockDeviceMapping] -> VirtualizationType-    -> [ResourceTag] -> Hypervisor -> Image-image i l s oid p pc a t kid rid pf-    sr oa n d rdt rdn bdms vt ts h =-    Image-        { imageId = i-        , imageLocation = l-        , imageImageState = s-        , imageOwnerId = oid-        , isPublic = p-        , imageProductCodes = pc-        , imageArchitecture = a-        , imageImageType = t-        , kernelId = kid-        , ramdiskId = rid-        , imagePlatform = pf-        , imageStateReason = sr-        , imageOwnerAlias = oa-        , imageName = n-        , imageDescription = d-        , imageRootDeviceType = rdt-        , imageRootDeviceName = rdn-        , blockDeviceMappings = bdms-        , imageVirtualizationType = vt-        , imageTagSet = ts-        , imageHypervisor = h-        }- data ImageState     = ImageAvailable     | ImagePending@@ -85,12 +52,6 @@     }   deriving (Show) -productCode :: Text -> ProductCodeType -> ProductCode-productCode c t = ProductCode-    { pcCode = c-    , pcType = t-    }- data ProductCodeType = Devpay                      | Marketplace   deriving (Show)@@ -129,13 +90,6 @@     }   deriving (Show) -stateReason :: Text -> Text -> StateReason-stateReason c m =-    StateReason-        { stateReasonCode = c-        , stateReasonMessage = m-        }- data RootDeviceType = EBS                     | InstanceStore   deriving (Show)@@ -153,15 +107,6 @@     }   deriving (Show) -blockDeviceMapping :: Text -> Maybe Text -> Maybe EbsBlockDevice-    -> BlockDeviceMapping-blockDeviceMapping dname v e =-    BlockDeviceMapping-        { deviceName = dname-        , virtualName = v-        , ebs = e-        }- data EbsBlockDevice = EbsBlockDevice     { ebsSnapshotId :: Maybe Text     , ebsVolumeSize :: Int@@ -170,17 +115,6 @@     }   deriving (Show) -ebsBlockDevice-    :: Maybe Text -> Int -> Bool -> VolumeType-    -> EbsBlockDevice-ebsBlockDevice sid vs dot vt =-    EbsBlockDevice-        { ebsSnapshotId = sid-        , ebsVolumeSize = vs-        , ebsDeleteOnTermination = dot-        , ebsVolumeType = vt-        }- data VolumeType = Standard                 | IO1 Int   deriving (Show)@@ -210,13 +144,6 @@     }   deriving (Show) -resourceTag :: Text -> Maybe Text -> ResourceTag-resourceTag k v =-    ResourceTag-        { resourceKey = k-        , resourceValue = v-        }- data Hypervisor = OVM                 | Xen   deriving (Show)@@ -234,13 +161,6 @@     }   deriving (Show) -region :: Text -> Text -> Region-region name rep = Region-    { regionName = name-    , regionEndpoint = rep-    }--{- DescribeAvailabilityZones -} data AvailabilityZone = AvailabilityZone     { zoneName :: Text     , zoneState :: Text@@ -251,18 +171,6 @@  type AvailabilityZoneMessage = Text -availabilityZone-    :: Text -> Text -> Text -> [AvailabilityZoneMessage]-    -> AvailabilityZone-availabilityZone name st reg msgs =-    AvailabilityZone-        { zoneName = name-        , zoneState = st-        , zoneRegionName = reg-        , messageSet = msgs-        }--{- DescribeInstances -} data Reservation = Reservation     { reservationId :: Text     , ownerId :: Text@@ -272,17 +180,6 @@     }   deriving (Show) -reservation-    :: Text -> Text -> [Group] -> [Instance] -> Maybe Text-    -> Reservation-reservation i o g iset rid = Reservation-    { reservationId = i-    , ownerId = o-    , groupSet = g-    , instanceSet = iset-    , requesterId = rid-    }- data Instance = Instance     { instanceId :: Text     , instanceImageId :: Text@@ -290,7 +187,7 @@     , privateDnsName :: Text     , dnsName :: Text     , reason :: Text-    , keyName :: Maybe Text+    , instanceKeyName :: Maybe Text     , amiLaunchIndex :: Text     , instanceProductCodes :: [ProductCode]     , instanceType :: Text@@ -323,61 +220,6 @@     }   deriving (Show) -ec2Instance-    :: Text -> Text -> InstanceState -> Text -> Text -> Text-    -> Maybe Text -> Text -> [ProductCode] -> Text -> UTCTime-    -> Placement -> Maybe Text -> Maybe Text -> Maybe Text-    -> InstanceMonitoringState -> Maybe Text -> Maybe Text-    -> Maybe Text -> Maybe Text -> Maybe Bool -> [Group]-    -> Maybe StateReason -> Architecture -> RootDeviceType-    -> Maybe Text -> [InstanceBlockDeviceMapping]-    -> InstanceLifecycle -> Maybe Text -> VirtualizationType-    -> Text -> [ResourceTag] -> Hypervisor-    -> [InstanceNetworkInterface] -> Maybe IamInstanceProfile-    -> Bool -> Instance-ec2Instance iid img istate pdns dns res kname aidx pcode-    itype ltime place kid rid pf mon snid vpcid paddr addr-    sdc grp sreason arch rdtype rdname bdmap life spotid-    vtype ctoken tset hv nicset iam eopt =-    Instance-        { instanceId = iid-        , instanceImageId = img-        , instanceState = istate-        , privateDnsName = pdns-        , dnsName = dns-        , reason = res-        , keyName = kname-        , amiLaunchIndex = aidx-        , instanceProductCodes = pcode-        , instanceType = itype-        , launchTime = ltime-        , instancePlacement = place-        , instanceKernelId = kid-        , instanceRamdiskId = rid-        , instancePlatform = pf-        , instanceMonitoring = mon-        , subnetId = snid-        , vpcId = vpcid-        , privateIpAddress = paddr-        , ipAddress = addr-        , sourceDestCheck = sdc-        , vpcGroupSet = grp-        , instanceStateReason = sreason-        , instanceArchitecture = arch-        , instanceRootDeviceType = rdtype-        , instanceRootDeviceName = rdname-        , instanceBlockDeviceMappings = bdmap-        , instanceInstanceLifecycle = life-        , spotInstanceRequestId = spotid-        , instanceVirtualizationType = vtype-        , clientToken = ctoken-        , instanceTagSet = tset-        , instanceHypervisor = hv-        , instanceNetworkInterfaceSet = nicset-        , instanceIamInstanceProfile = iam-        , ebsOptimized = eopt-        }- data InstanceStatus = InstanceStatus     { isInstanceId :: Text     , isAvailabilityZone :: Text@@ -388,18 +230,6 @@     }   deriving (Show) -instanceStatus :: Text -> Text -> [InstanceStatusEvent]-    -> InstanceState -> InstanceStatusType-    -> InstanceStatusType -> InstanceStatus-instanceStatus iid az es ist sst iss = InstanceStatus-    { isInstanceId = iid-    , isAvailabilityZone = az-    , isEventsSet = es-    , isInstanceState = ist-    , isSystemStatus = sst-    , isInstanceStatus = iss-    }- data InstanceStatusEvent = InstanceStatusEvent     { iseCode :: InstanceStatusEventCode     , iseDescription :: Text@@ -408,16 +238,6 @@     }   deriving (Show) -instanceStatusEvent :: InstanceStatusEventCode-    -> Text -> Maybe UTCTime -> Maybe UTCTime-    -> InstanceStatusEvent-instanceStatusEvent code desc before after = InstanceStatusEvent-    { iseCode = code-    , iseDescription = desc-    , iseNotBefore = before-    , iseNotAfter = after-    }- data InstanceStatusEventCode     = InstanceReboot     | InstanceStop@@ -439,13 +259,6 @@     }   deriving (Show) -instanceStatusType :: InstanceStatusTypeStatus-    -> [InstanceStatusDetail] -> InstanceStatusType-instanceStatusType status details = InstanceStatusType-    { isdStatus = status-    , isdDetails = details-    }- data InstanceStatusTypeStatus     = InstanceStatusOK     | InstanceStatusImpaired@@ -468,16 +281,6 @@     }   deriving (Show) -instanceStatusDetail :: InstanceStatusDetailName-    -> InstanceStatusDetailStatus -> Maybe UTCTime-    -> InstanceStatusDetail-instanceStatusDetail name status since =-    InstanceStatusDetail-        { isddName = name-        , isddStatus = status-        , isddImpairedSince = since-        }- type InstanceStatusDetailName = Text  type InstanceStatusDetailStatus = Text@@ -488,12 +291,6 @@     }   deriving (Show) -group :: Text -> Text -> Group-group i n = Group-    { groupId = i-    , groupName = n-    }- data InstanceState     = Pending     | Running@@ -525,13 +322,6 @@     }   deriving (Show) -placement :: Text -> Text -> Text -> Placement-placement zone gname ten = Placement-    { placementAvailabilityZone = zone-    , placementGroupName = gname-    , tenancy = ten-    }- data InstanceMonitoringState     = MonitoringDisabled     | MonitoringEnabled@@ -559,15 +349,6 @@     }   deriving (Show) -instanceBlockDeviceMapping-    :: Text -> InstanceEbsBlockDevice-    -> InstanceBlockDeviceMapping-instanceBlockDeviceMapping devname iebs =-    InstanceBlockDeviceMapping-        { instanceDeviceName = devname-        , instanceEbs = iebs-        }- data InstanceEbsBlockDevice = InstanceEbsBlockDevice     { instanceEbsVolumeId :: Text     , instanceEbsState :: AttachmentStatus@@ -576,17 +357,6 @@     }   deriving (Show) -instanceEbsBlockDevice-    :: Text -> AttachmentStatus -> UTCTime -> Bool-    -> InstanceEbsBlockDevice-instanceEbsBlockDevice vid vst atime dot =-    InstanceEbsBlockDevice-        { instanceEbsVolumeId = vid-        , instanceEbsState = vst-        , instanceEbsAttachTime = atime-        , instanceEbsDeleteOnTermination = dot-        }- data InstanceLifecycle = LifecycleSpot | LifecycleNone   deriving (Show) @@ -613,30 +383,6 @@     }   deriving (Show) -instanceNetworkInterface-    :: Text -> Text -> Text -> Text -> Text -> Text -> Text-    -> Maybe Text -> Bool -> [Group] -> NetworkInterfaceAttachment-    -> Maybe NetworkInterfaceAssociation-    -> [InstancePrivateIpAddress]-    -> InstanceNetworkInterface-instanceNetworkInterface-    iid sid vpcid desc own st paddr pdns sdc grp att asso pips =-    InstanceNetworkInterface-        { instanceNetworkInterfaceId = iid-        , iniSubnetId = sid-        , iniVpcId = vpcid-        , iniDescription = desc-        , iniOwnerId = own-        , iniStatus = st-        , iniPrivateIpAddress = paddr-        , iniPrivateDnsName = pdns-        , iniSourceDestCheck = sdc-        , iniGroupSet = grp-        , iniAttachment = att-        , iniAssociation = asso-        , iniPrivateIpAddressSet = pips-        }- data NetworkInterfaceAttachment = NetworkInterfaceAttachment     { niatAttachmentId :: Text     , niatDeviceIndex :: Int@@ -646,32 +392,12 @@     }   deriving (Show) -networkInterfaceAttachment-    :: Text -> Int -> Text -> UTCTime -> Bool-    -> NetworkInterfaceAttachment-networkInterfaceAttachment aid idx st time dot =-    NetworkInterfaceAttachment-        { niatAttachmentId = aid-        , niatDeviceIndex = idx-        , niatStatus = st-        , niatAttachTime = time-        , niatDeleteOnTermination = dot-        }- data NetworkInterfaceAssociation = NetworkInterfaceAssociation     { niasPublicIp :: Text     , niasIpOwnerId :: Text     }   deriving (Show) -networkInterfaceAssociation-    :: Text -> Text -> NetworkInterfaceAssociation-networkInterfaceAssociation ip own =-    NetworkInterfaceAssociation-        { niasPublicIp = ip-        , niasIpOwnerId = own-        }- data InstancePrivateIpAddress = InstancePrivateIpAddress     { iPrivateIpAddress :: Text     , iPrimary :: Bool@@ -679,28 +405,38 @@     }   deriving (Show) -instancePrivateIpAddress-    :: Text -> Bool -> Maybe NetworkInterfaceAssociation-    -> InstancePrivateIpAddress-instancePrivateIpAddress ip pr asso =-    InstancePrivateIpAddress-        { iPrivateIpAddress = ip-        , iPrimary = pr-        , iAssociation = asso-        }- data IamInstanceProfile = IamInstanceProfile     { iipArn :: Text     , iipId :: Text     }   deriving (Show) -iamInstanceProfile :: Text -> Text -> IamInstanceProfile-iamInstanceProfile arn iid = IamInstanceProfile-    { iipArn = arn-    , iipId = iid-    }+data ShutdownBehavior+    = SBStop+    | SBTerminate+  deriving (Show) +shutdownBehavior :: Text -> ShutdownBehavior+shutdownBehavior t+    | t == "stop"      = SBStop+    | t == "terminate" = SBTerminate+    | otherwise = err "shutdown behavior" t++data InstanceAttribute+    = IAInstanceType Text+    | IAKernelId (Maybe Text)+    | IARamdiskId (Maybe Text)+    | IAUserData (Maybe Text)+    | IADisableApiTermination Bool+    | IAShutdownBehavior ShutdownBehavior+    | IARootDeviceName (Maybe Text)+    | IABlockDeviceMapping [InstanceBlockDeviceMapping]+    | IASourceDestCheck (Maybe Bool)+    | IAGroupSet [Text]+    | IAProductCodes [ProductCode]+    | IAEbsOptimized Bool+  deriving (Show)+ data Address = Address     { addrPublicIp :: Text     , addrAllocationId :: Maybe Text@@ -713,20 +449,6 @@     }   deriving (Show) -address :: Text -> Maybe Text -> AddressDomain -> Maybe Text-    -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text-    -> Address-address pip alid dom iid asid niid nioid pips = Address-    { addrPublicIp = pip-    , addrAllocationId = alid-    , addrDomain = dom-    , addrInstanceId = iid-    , addrAssociationId = asid-    , addrNetworkInterfaceId = niid-    , addrNetworkInterfaceOwnerId = nioid-    , addrPrivateIpAddress = pips-    }- data AddressDomain = AddressDomainStandard | AddressDomainVPC   deriving (Show) @@ -744,15 +466,6 @@     }   deriving (Show) -allocateAddressResponse :: Text -> AddressDomain -> Maybe Text-    -> AllocateAddressResponse-allocateAddressResponse ip domain allid =-    AllocateAddressResponse-        { alaPublicIp = ip-        , alaDomain = domain-        , alaAllocationId = allid-        }- data EC2Return = EC2Success | EC2Error Text   deriving (Show) @@ -769,14 +482,6 @@     }   deriving (Show) -tag :: Text -> Text -> Text -> Maybe Text -> Tag-tag tid ttype key value = Tag-    { tagResourceId = tid-    , tagResourceType = ttype-    , tagKey = key-    , tagValue = value-    }- data InstanceStateChange = InstanceStateChange     { iscInstanceId :: Text     , iscCurrentState :: InstanceState@@ -784,14 +489,6 @@     }   deriving (Show) -instanceStateChange :: Text -> InstanceState -> InstanceState-    -> InstanceStateChange-instanceStateChange iid curr prev = InstanceStateChange-    { iscInstanceId = iid-    , iscCurrentState = curr-    , iscPreviousState = prev-    }- data ConsoleOutput = ConsoleOutput     { coInstanceId :: Text     , coTimestamp :: UTCTime -- ^ The time the data was last updated.@@ -799,13 +496,6 @@     }   deriving (Show) -consoleOutput :: Text -> UTCTime -> Text -> ConsoleOutput-consoleOutput iid time out = ConsoleOutput-    { coInstanceId = iid-    , coTimestamp = time-    , coOutput = out-    }- data PasswordData = PasswordData     { pdInstanceId :: Text     , pdTimestamp :: UTCTime -- ^ The time the data was last updated.@@ -813,13 +503,6 @@     }   deriving (Show) -passwordData :: Text -> UTCTime -> Text -> PasswordData-passwordData iid time out = PasswordData-    { pdInstanceId = iid-    , pdTimestamp = time-    , pdPasswordData = out-    }- data Snapshot = Snapshot     { snapshotId :: Text     , ssVolumeId :: Text@@ -834,23 +517,6 @@     }   deriving (Show) -snapshot :: Text -> Text -> SnapshotStatus -> UTCTime-    -> Text -> Text -> Int -> Text -> Maybe Text-    -> [ResourceTag] -> Snapshot-snapshot ssid vid stat stime progress oid vsize desc oali tags =-    Snapshot-    { snapshotId = ssid-    , ssVolumeId = vid-    , ssStatus = stat-    , ssStartTime = stime-    , ssProgress = progress-    , ssOwnerId = oid-    , ssVolumeSize = vsize-    , ssDescription = desc-    , ssOwnerAlias = oali-    , ssTagSet = tags-    }- data SnapshotStatus = SSPending | SSCompleted | SSError   deriving (Show) @@ -874,20 +540,6 @@     }   deriving (Show) -volume :: Text -> Int -> Maybe Text -> Text -> VolumeStatus -> UTCTime-    -> [Attachment] -> [ResourceTag] -> VolumeType -> Volume-volume vid size sid az stat ctime aset tset vtype = Volume-    { volumeId = vid-    , volSize = size-    , volSnapshotId = sid-    , volAvailabilityZone = az-    , volStatus = stat-    , volCreateTime = ctime-    , volAttachmentSet = aset-    , volTagSet = tset-    , volVolumeType = vtype-    }- data VolumeStatus     = VolCreating     | VolAvailable@@ -913,21 +565,10 @@     , attDevice :: Text     , attStatus :: AttachmentStatus     , attAttachTime :: UTCTime-    , attDeleteOnTermination :: Bool+    , attDeleteOnTermination :: Maybe Bool     }   deriving (Show) -attachment :: Text -> Text -> Text -> AttachmentStatus-    -> UTCTime -> Bool -> Attachment-attachment vid iid dev stat atime dot = Attachment-    { attVolumeId = vid-    , attInstanceId = iid-    , attDevice = dev-    , attStatus = stat-    , attAttachTime = atime-    , attDeleteOnTermination = dot-    }- data AttachmentStatus     = AttAttaching     | AttAttached@@ -942,3 +583,73 @@     | t == "detaching" = AttDetaching     | t == "detached"  = AttDetached     | otherwise        = err "attachment status" t++data KeyPair = KeyPair+    { keyName :: Text+    , keyFingerprint :: Text+    }+  deriving (Show)++data SecurityGroup = SecurityGroup+    { sgOwnerId :: Text+    , sgGroupId :: Text+    , sgGroupName :: Text+    , sgGroupDescription :: Text+    , sgVpcId :: Maybe Text+    , sgIpPermissions :: [IpPermission]+    , sgIpPermissionsEgress :: [IpPermission]+    , sgTagSet :: [ResourceTag]+    }+  deriving (Show)++data IpPermission = IpPermission+    { ippIpProtocol :: Text+    , ippFromPort :: Maybe Int+    , ippToPort :: Maybe Int+    , ippGroups :: [UserIdGroupPair]+    , ippIpRanges :: [IpRange]+    }+  deriving (Show)++data UserIdGroupPair = UserIdGroupPair+    { uigpUserId :: Maybe Text+    , uigpGroupId :: Text+    , uigpGroupName :: Maybe Text+    }+  deriving (Show)++data IpRange = IpRange+    { iprCidrIp :: Text+    }+  deriving (Show)++data BlockDeviceMappingParam+    = BlockDeviceMappingParamEBS+        { bdmpEbsDeviceName :: Text+        , bdmpEbsNoDevice :: Maybe Bool+        , bdmpEbsSource :: EbsSource+        , bdmpEbsDeleteOnTermination :: Maybe Bool+        , bdmpEbsVolumeType :: Maybe VolumeType+        }+    | BlockDeviceMappingParamInstanceStore+        { bdmpIsDeviceName :: Text+        , bdmpIsNoDevice :: Maybe Bool+        , bdmpIsVirtualName :: Maybe Text+        }+  deriving (Show)++data EbsSource+    = EbsSnapshotId Text+    | EbsVolumeSize Int+  deriving (Show)++data NetworkInterfaceParam = NetworkInterfaceParam+    { nipInterfaceId :: Maybe Text+    , nipDeviceIndex :: Maybe Text+    , nipSubnetId :: Maybe Text+    , nipDescription :: Maybe Text+    , nipPrivateIpAddresses :: [Text]+    , nipSecurityGroupIds :: [Text]+    , nipDeleteOnTermination :: Maybe Bool+    }+  deriving (Show)

@@ -1,39 +1,2 @@ module AWS.EC2.Utils where -import Control.Applicative-import qualified Data.Text as T--import AWS.EC2.Query (QueryParam(..))-import AWS.EC2.Types-import AWS.EC2.Params-import AWS.Util--blockDeviceMappingParams-    :: [BlockDeviceMappingParam] -> QueryParam-blockDeviceMappingParams =-    StructArrayParams "BlockDeviceMapping" . map kvs-  where-    kvs (BlockDeviceMappingParamEBS name dev src dot vtype) = -        [ ("Ebs.DeviceName", name)-        , ebsSource src-        ] ++ vtparam vtype ++ (uncurry f =<<-            [ ("Ebs.NoDevice", boolToText <$> dev)-            , ("Ebs.DeleteOnTermination", boolToText <$> dot)-            ])-    kvs (BlockDeviceMappingParamInstanceStore name dev vname) =-        [("Ebs.DeviceName", name)] ++ (uncurry f =<<-            [ ("Ebs.NoDevice", boolToText <$> dev)-            , ("Ebs.VirtualName", vname)-            ])--    ebsSource (EbsSnapshotId sid) = ("Ebs.SnapshotId", sid)-    ebsSource (EbsVolumeSize size) =-        ("Ebs.VolumeSize", T.pack $ show size)--    f n = maybe [] (\a -> [(n, a)])-    vtparam Nothing = []-    vtparam (Just Standard) = [("Ebs.VolumeType", "standard")]-    vtparam (Just (IO1 iops)) =-        [ ("Ebs.VolumeType", "io1")-        , ("Ebs.Iops", T.pack $ show iops)-        ]

@@ -1,9 +1,12 @@ {-# LANGUAGE FlexibleContexts #-}- module AWS.EC2.Volume     ( describeVolumes-    ) where-+    , createVolume+    , CreateVolumeParam(..)+    , deleteVolume+    , attachVolume+    , detachVolume+    ) where  import Data.Text (Text)  import Data.XML.Types (Event)@@ -23,30 +26,115 @@     -> [Filter] -- ^ Filters     -> EC2 m (Source m Volume) describeVolumes vids filters =-    ec2QuerySource "DescribeVolumes" params volumeSet+    ec2QuerySource "DescribeVolumes" params $+        itemConduit "volumeSet" volumeSink   where     params =         [ ArrayParams "VolumeId" vids         , FilterParams filters         ]-    volumeSet :: MonadThrow m-        => GLConduit Event m Volume-    volumeSet = itemConduit "volumeSet" $-        volume-        <$> getT "volumeId"-        <*> getF "size" textToInt-        <*> getMT "snapshotId"-        <*> getT "availabilityZone"-        <*> getF "status" volumeStatus-        <*> getF "createTime" textToTime-        <*> itemsSet "attachmentSet" (-            attachment-            <$> getT "volumeId"-            <*> getT "instanceId"-            <*> getT "device"-            <*> getF "status" attachmentStatus-            <*> getF "attachTime" textToTime-            <*> getF "deleteOnTermination" textToBool-            )-        <*> resourceTagSink-        <*> volumeTypeSink++volumeSink :: MonadThrow m+    => GLSink Event m Volume+volumeSink = Volume+    <$> getT "volumeId"+    <*> getF "size" textToInt+    <*> getMT "snapshotId"+    <*> getT "availabilityZone"+    <*> getF "status" volumeStatus+    <*> getF "createTime" textToTime+    <*> itemsSet "attachmentSet" attachmentSink+    <*> resourceTagSink+    <*> volumeTypeSink++attachmentSink :: MonadThrow m => GLSink Event m Attachment+attachmentSink = Attachment+    <$> getT "volumeId"+    <*> getT "instanceId"+    <*> getT "device"+    <*> getF "status" attachmentStatus+    <*> getF "attachTime" textToTime+    <*> getM "deleteOnTermination" (textToBool <$>)++volumeTypeParam :: VolumeType -> [QueryParam]+volumeTypeParam Standard = [ValueParam "VolumeType" "standard"]+volumeTypeParam (IO1 iops) =+    [ ValueParam "VolumeType" "io1"+    , ValueParam "Iops" $ toText iops+    ]++createVolume+    :: (MonadResource m, MonadBaseControl IO m)+    => CreateVolumeParam+    -> EC2 m Volume+createVolume param =+    ec2Query "CreateVolume" param' volumeSink+  where+    param' = createVolumeParam param++data CreateVolumeParam+    = CreateNewVolume+        { cnvSize :: Int+        , cnvAvailabilityZone :: Text+        , cnvVolumeType :: Maybe VolumeType+        }+    | CreateFromSnapshot+        { cfsSnapshotId :: Text+        , cfsAvailabilityZone :: Text+        , cfsSize :: Maybe Int+        , cfsVolumeType :: Maybe VolumeType+        }+  deriving (Show)++createVolumeParam :: CreateVolumeParam -> [QueryParam]+createVolumeParam (CreateNewVolume size zone vtype) =+    [ ValueParam "Size" $ toText size+    , ValueParam "AvailabilityZone" zone+    ] ++ maybe [] volumeTypeParam vtype+createVolumeParam (CreateFromSnapshot sid zone size vtype) =+    [ ValueParam "SnapshotId" sid+    , ValueParam "AvailabilityZone" zone+    ]+    ++ maybe [] (\a -> [ValueParam "Size" $ toText a]) size+    ++ maybe [] volumeTypeParam vtype++deleteVolume+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ VolumeId+    -> EC2 m Bool+deleteVolume volid =+    ec2Query "DeleteVolume" [ValueParam "VolumeId" volid]+        $ getF "return" textToBool++attachVolume+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ VolumeId+    -> Text -- ^ InstanceId+    -> Text -- ^ Device+    -> EC2 m Attachment+attachVolume volid iid dev =+    ec2Query "AttachVolume" params attachmentSink+  where+    params =+        [ ValueParam "VolumeId" volid+        , ValueParam "InstanceId" iid+        , ValueParam "Device" dev+        ]++detachVolume+    :: (MonadResource m, MonadBaseControl IO m)+    => Text -- ^ VolumeId+    -> Maybe Text -- ^ InstanceId+    -> Maybe Text -- ^ Device+    -> Maybe Bool -- ^ Force+    -> EC2 m Attachment+detachVolume volid iid dev force =+    ec2Query "DetachVolume" params attachmentSink+  where+    mk name = maybe [] (\a -> [ValueParam name a])+    params = [ValueParam "VolumeId" volid]+        ++ (uncurry mk =<<+            [ ("InstanceId", iid)+            , ("Device", dev)+            , ("Force", toText <$> force)+            ])

@@ -9,7 +9,7 @@ import qualified Data.Text.Read as TR import Data.Time (UTCTime) import qualified Data.Time as Time-import System.Locale (defaultTimeLocale)+import qualified Data.Time.Parse as TP  toS :: BSL.ByteString -> ByteString toS = BS.concat . BSL.toChunks@@ -33,12 +33,16 @@ textToInt t = either      (const $ error "not decimal")     fst-    (TR.decimal t)+    (TR.signed TR.decimal t)  textToTime :: Text -> UTCTime-textToTime = Time.readTime defaultTimeLocale fmt . T.unpack+textToTime+    = Time.localTimeToUTC Time.utc+    . maybe (error "time format error.") fst+    . TP.strptime fmt+    . T.unpack   where-    fmt = "%FT%T.000Z"+    fmt = "%FT%T"  orEmpty :: Maybe Text -> Text orEmpty = maybe "" id

@@ -1,5 +1,5 @@ name:                aws-sdk-version:             0.1.2.0+version:             0.2.0.0 synopsis:            AWS SDK for Haskell description:         An AWS(Amazon Web Services) liblary for Haskell. license:             BSD3@@ -8,7 +8,7 @@ maintainer:          Yusuke Nomura <yunomu@gmail.com> homepage:            http://worksap-ate.github.com/aws-sdk copyright:           AWS SDK for Haskell Developers-category:            Cloud, AWS+category:            Cloud, AWS, Distributed Computing build-type:          Simple cabal-version:       >=1.8 @@ -17,7 +17,7 @@                    , AWS.Types                    , AWS.EC2                    , AWS.EC2.Types-                   , AWS.EC2.Params+                   , AWS.EC2.Utils   other-modules:     AWS.Util                    , AWS.Credential                    , AWS.EC2.Address@@ -25,15 +25,17 @@                    , AWS.EC2.Image                    , AWS.EC2.Instance                    , AWS.EC2.Volume+                   , AWS.EC2.KeyPair                    , AWS.EC2.Snapshot+                   , AWS.EC2.SecurityGroup                    , AWS.EC2.Parser                    , AWS.EC2.Query                    , AWS.EC2.Region                    , AWS.EC2.Tag                    , AWS.EC2.Class-                   , AWS.EC2.Utils                    , AWS.EC2.Parser                    , AWS.EC2.Parser.Internal+                   , AWS.EC2.Params   ghc-options:       -Wall                      -fno-warn-unused-do-bind   extensions: OverloadedStrings@@ -59,6 +61,7 @@                    , mtl                    , lifted-base                    , transformers-base+                   , strptime  test-suite test     type:              exitcode-stdio-1.0