diff --git a/AWS.hs b/AWS.hs new file mode 100644 --- /dev/null +++ b/AWS.hs @@ -0,0 +1,39 @@ +-- | aws-sdk is an AWS library for Haskell +-- +-- Put your AWS AccessKey and SecretAccessKey into a configuration +-- file. Write the following in /./\//aws.config/. +-- +-- > accessKey: your-access-key +-- > secretAccessKey: your-secret-access-key +-- +-- The followin is quick example(DescribeInstances). +-- +-- > module Example where +-- > +-- > import Data.Conduit +-- > import qualified Data.Conduit.List as CL +-- > import Control.Monad.IO.Class (liftIO) +-- > import Control.Monad.Trans.Class (lift) +-- > +-- > import AWS +-- > import AWS.EC2 +-- > +-- > main :: IO () +-- > main = do +-- > cred <- loadCredential +-- > doc <- runResourceT $ do +-- > ctx <- liftIO $ newEC2Context cred +-- > runEC2 ctx $ do +-- > response <- describeInstances [] [] +-- > lift $ response $$ CL.consume +-- > print doc +-- > putStr "Length: " +-- > print $ length doc +{-# LANGUAGE OverloadedStrings #-} +module AWS + ( -- * Credentials + Credential + , loadCredential + ) where + +import AWS.Credential diff --git a/AWS/Credential.hs b/AWS/Credential.hs new file mode 100644 --- /dev/null +++ b/AWS/Credential.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +module AWS.Credential + ( Credential(..) + , AccessKey + , SecretAccessKey + , loadCredential + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Text.Config +import Text.Parsec + +mkConfig "configParser" [config| +Credential + accessKey ByteString + secretAccessKey ByteString +|] + +type AccessKey = ByteString +type SecretAccessKey = ByteString + +loadCredential :: IO Credential +loadCredential = do + str <- BS.readFile "aws.config" + case parse configParser "" str of + Left err -> fail $ show err + Right conf -> return conf diff --git a/AWS/EC2.hs b/AWS/EC2.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module AWS.EC2 + ( -- * EC2 Environment + module AWS.EC2.Class + , EC2Endpoint(..) + , newEC2Context + , setEndpoint + -- * Instances + , module AWS.EC2.Instance + -- * Images + , module AWS.EC2.Image + -- * 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 AWS.Types +import AWS.EC2.Class + +import AWS.EC2.Image +import AWS.EC2.Region +import AWS.EC2.AvailabilityZone +import AWS.EC2.Instance +import AWS.EC2.Address +import AWS.EC2.Tag +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 + } + +setEndpoint + :: (MonadResource m, MonadBaseControl IO m) + => EC2Endpoint -> EC2 m () +setEndpoint ep = do + ctx <- ST.get + ST.put ctx { endpoint = ep } diff --git a/AWS/EC2/Address.hs b/AWS/EC2/Address.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Address.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleContexts #-} + +module AWS.EC2.Address + ( describeAddresses + , allocateAddress + , releaseAddress + , associateAddress + , AssociateAddressParam(..) + ) 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 + +----------------------------------------------------- +-- DescribeAddresses +----------------------------------------------------- +describeAddresses + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ PublicIps + -> [Text] -- ^ AllocationIds + -> [Filter] -- ^ Filters + -> EC2 m (Source m Address) +describeAddresses pubIps alloIds filters = + ec2QuerySource "DescribeAddresses" params addressSet where + params = + [ ArrayParams "PublicIp" pubIps + , ArrayParams "AllocationId" alloIds + , FilterParams filters + ] + + addressSet :: MonadThrow m => GLConduit Event m Address + addressSet = itemConduit "addressesSet" $ address + <$> getT "publicIp" + <*> getMT "allocationId" + <*> getM "domain" addressDomain + <*> getMT "instanceId" + <*> getMT "associationId" + <*> getMT "networkInterfaceId" + <*> getMT "networkInterfaceOwnerId" + <*> getMT "privateIpAddress" + +----------------------------------------------------- +-- AllocateAddress +----------------------------------------------------- +allocateAddress + :: (MonadResource m, MonadBaseControl IO m) + => Bool -- ^ is VPC? + -> EC2 m AllocateAddressResponse +allocateAddress isVpc = do + ec2Query "AllocateAddress" params $ + allocateAddressResponse + <$> getT "publicIp" + <*> getM "domain" addressDomain + <*> getMT "allocationId" + where + params = if isVpc then [ValueParam "Domain" "vpc"] else [] + +----------------------------------------------------- +-- ReleaseAddress +----------------------------------------------------- +releaseAddress + :: (MonadResource m, MonadBaseControl IO m) + => Maybe Text -- ^ PublicIp + -> Maybe Text -- ^ AllocationId + -> EC2 m EC2Return +releaseAddress addr allocid = do + ec2Query "ReleaseAddress" params $ getF "return" ec2Return + where + param name = maybe [] (\a -> [ValueParam name a]) + params = uncurry param =<< + [ ("PublicIp", addr) + , ("AllocationId", allocid) + ] + +----------------------------------------------------- +-- AssociateAddress +----------------------------------------------------- +associateAddress + :: (MonadResource m, MonadBaseControl IO m) + => AssociateAddressParam + -> EC2 m (Bool, Maybe Text) +associateAddress param = ec2Query "AssociateAddress" params $ + (,) <$> getF "return" textToBool + <*> getMT "associationId" + where + params = associateAddressParam param + +data AssociateAddressParam + = AAEC2Instance + { aaec2PublicIp :: Text + , aaec2InstanceId :: Text + } + | AAVPCInstance + { aavpcAllocationId :: Text + , aavpcInstanceId :: Maybe Text + , aavpcNetworkInterfaceId :: Maybe Text + , aavpcPrivateIpAddress :: Maybe Text + , aavpcAllowReassociation :: Maybe Bool + } + deriving (Show) + +associateAddressParam + :: AssociateAddressParam -> [QueryParam] +associateAddressParam (AAEC2Instance ip iid) = + [ ValueParam "PublicIp" ip + , ValueParam "InstanceId" iid + ] +associateAddressParam (AAVPCInstance aid iid nid pip ar) = + [ ValueParam "AllocationId" aid ] + ++ (uncurry f =<< + [ ("InstanceId", iid) + , ("NetworkInterfaceId", nid) + , ("PrivateIpAddress", pip) + , ("AllowReassociation", boolToText <$> ar) + ]) + where + f name = maybe [] (\a -> [ValueParam name a]) diff --git a/AWS/EC2/AvailabilityZone.hs b/AWS/EC2/AvailabilityZone.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/AvailabilityZone.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} + +module AWS.EC2.AvailabilityZone + ( describeAvailabilityZones + ) 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 + +describeAvailabilityZones + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ ZoneNames + -> [Filter] -- ^ Filters + -> EC2 m (Source m AvailabilityZone) +describeAvailabilityZones zones filters = + ec2QuerySource "DescribeAvailabilityZones" params availabilityZoneInfo + where + params = + [ ArrayParams "ZoneName" zones + , FilterParams filters + ] + availabilityZoneInfo :: MonadThrow m + => GLConduit Event m AvailabilityZone + availabilityZoneInfo = itemConduit "availabilityZoneInfo" $ + availabilityZone + <$> getT "zoneName" + <*> getT "zoneState" + <*> getT "regionName" + <*> itemsSet "messageSet" (getT "message") diff --git a/AWS/EC2/Class.hs b/AWS/EC2/Class.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Class.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , TypeFamilies + , FlexibleInstances + , MultiParamTypeClasses + , UndecidableInstances + , DeriveDataTypeable + #-} + +module AWS.EC2.Class + ( EC2 + , runEC2 + , ResponseParserException(..) + , EC2Context(..) + ) where + +import Control.Monad.State (StateT(..), MonadState) +import qualified Control.Monad.State as S +import Control.Applicative +import Control.Monad (liftM) +import Control.Monad.Base (MonadBase) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.Trans.Control + ( MonadBaseControl(..) + , MonadTransControl(..) + , ComposeSt + , defaultLiftBaseWith + , defaultRestoreM + ) +import Control.Exception (Exception) +import Data.Typeable (Typeable) + +import qualified Network.HTTP.Conduit as HTTP +import Data.Text (Text) + +import AWS.Types +import AWS.Credential + +data EC2Context = EC2Context + { manager :: HTTP.Manager + , credential :: Credential + , endpoint :: EC2Endpoint + , lastRequestId :: Maybe Text + } + +data ResponseParserException + = NextToken Text + deriving (Show, Typeable) + +instance Exception ResponseParserException + +newtype EC2 m a = EC2T + { runEC2T :: StateT EC2Context m a + } deriving + ( Monad + , Applicative + , Functor + , MonadIO + , MonadState EC2Context + , MonadBase base + ) + +instance MonadTrans EC2 where + lift = EC2T . lift + +instance MonadTransControl EC2 where + newtype StT EC2 a = StEC2 { unStEC2 :: (a, EC2Context) } + liftWith f = EC2T . StateT $ \s -> + liftM (\x -> (x, s)) + (f $ \a -> liftM StEC2 + (S.runStateT (runEC2T a) s)) + restoreT = EC2T . StateT . 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 diff --git a/AWS/EC2/Image.hs b/AWS/EC2/Image.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Image.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleContexts #-} + +module AWS.EC2.Image + ( describeImages + , createImage + ) 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.Utils +import AWS.EC2.Params +import AWS.EC2.Class +import AWS.EC2.Query +import AWS.EC2.Parser +import AWS.Util + +describeImages + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ ImageIds + -> [Text] -- ^ Owners (User Ids) + -> [Text] -- ^ ExecutedBy (User Ids) + -> [Filter] -- ^ Filers + -> EC2 m (Source m Image) +describeImages imageIds owners execby filters = + ec2QuerySource "DescribeImages" params $ + itemConduit "imagesSet" imageItem + where + params = + [ ArrayParams "ImageId" imageIds + , ArrayParams "Owner" owners + , ArrayParams "ExecutableBy" execby + , FilterParams filters + ] + +imageItem :: MonadThrow m + => GLSink Event m Image +imageItem = image + <$> getT "imageId" + <*> getT "imageLocation" + <*> getF "imageState" imageState + <*> getT "imageOwnerId" + <*> getF "isPublic" textToBool + <*> productCodeSink + <*> getT "architecture" + <*> getF "imageType" imageType + <*> getMT "kernelId" + <*> getMT "ramdiskId" + <*> getM "platform" platform + <*> stateReasonSink + <*> getMT "imageOwnerAlias" + <*> getM "name" orEmpty + <*> getM "description" orEmpty + <*> getF "rootDeviceType" rootDeviceType + <*> getMT "rootDeviceName" + <*> itemsSet "blockDeviceMapping" ( + blockDeviceMapping + <$> getT "deviceName" + <*> getMT "virtualName" + <*> elementM "ebs" ( + ebsBlockDevice + <$> getMT "snapshotId" + <*> getF "volumeSize" textToInt + <*> getF "deleteOnTermination" textToBool + <*> (volumeType + <$> getT "volumeType" + <*> getM "iops" (textToInt <$>) + ) + ) + ) + <*> getF "virtualizationType" virtualizationType + <*> resourceTagSink + <*> getF "hypervisor" hypervisor + +createImage + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ InstanceId + -> Text -- ^ Name + -> Maybe Text -- ^ Description + -> Bool -- ^ NoReboot + -> [BlockDeviceMappingParam] -- ^ BlockDeviceMapping + -> EC2 m Text +createImage iid name desc noReboot bdms = + ec2Query "CreateImage" params $ getT "imageId" + where + param n = maybe [] (\a -> [ValueParam n a]) + params = + [ ValueParam "InstanceId" iid + , ValueParam "Name" name + , ValueParam "NoReboot" (boolToText noReboot) + ] ++ param "Description" desc + ++ [blockDeviceMappingParams bdms] diff --git a/AWS/EC2/Instance.hs b/AWS/EC2/Instance.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Instance.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE FlexibleContexts #-} + +module AWS.EC2.Instance + ( describeInstances + , runInstances + , RunInstancesParam(..) + , defaultRunInstancesParam + , terminateInstances + , startInstances + , stopInstances + , rebootInstances + , getConsoleOutput + , getPasswordData + , describeInstanceStatus + ) 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 AWS.EC2.Types +import AWS.EC2.Params +import AWS.EC2.Utils +import AWS.EC2.Class +import AWS.EC2.Query +import AWS.EC2.Parser +import AWS.Util + +------------------------------------------------------------ +-- DescribeInstances +------------------------------------------------------------ +describeInstances + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ InstanceIds + -> [Filter] -- ^ Filters + -> EC2 m (Source m Reservation) +describeInstances instances filters = do + ec2QuerySource "DescribeInstances" params $ + itemConduit "reservationSet" reservationSink + where + params = + [ ArrayParams "InstanceId" instances + , FilterParams filters + ] + +reservationSink :: MonadThrow m + => GLSink Event m Reservation +reservationSink = + reservation + <$> getT "reservationId" + <*> getT "ownerId" + <*> groupSetSink + <*> instanceSetSink + <*> getMT "requesterId" + +groupSetSink :: MonadThrow m => GLSink Event m [Group] +groupSetSink = itemsSet "groupSet" $ group + <$> getT "groupId" + <*> getT "groupName" + +instanceSetSink :: MonadThrow m + => GLSink Event m [Instance] +instanceSetSink = itemsSet "instancesSet" $ + ec2Instance + <$> getT "instanceId" + <*> getT "imageId" + <*> instanceStateSink "instanceState" + <*> getT "privateDnsName" + <*> getT "dnsName" + <*> getT "reason" + <*> getMT "keyName" + <*> getT "amiLaunchIndex" + <*> productCodeSink + <*> getT "instanceType" + <*> getF "launchTime" textToTime + <*> element "placement" ( + placement + <$> getT "availabilityZone" + <*> getT "groupName" + <*> getT "tenancy" + ) + <*> getMT "kernelId" + <*> getMT "ramdiskId" + <*> getMT "platform" + <*> element "monitoring" (getF "state" instanceMonitoringState) + <*> getMT "subnetId" + <*> getMT "vpcId" + <*> getMT "privateIpAddress" + <*> getMT "ipAddress" + <*> getM "sourceDestCheck" (textToBool <$>) + <*> groupSetSink + <*> stateReasonSink + <*> getF "architecture" architecture + <*> getF "rootDeviceType" rootDeviceType + <*> getMT "rootDeviceName" + <*> itemsSet "blockDeviceMapping" ( + instanceBlockDeviceMapping + <$> getT "deviceName" + <*> element "ebs" ( + instanceEbsBlockDevice + <$> getT "volumeId" + <*> getF "status" volumeState + <*> getF "attachTime" textToTime + <*> getF "deleteOnTermination" textToBool + ) + ) + <*> getM "instanceLifecycle" instanceLifecycle + <*> getMT "spotInstanceRequestId" + <*> getF "virtualizationType" virtualizationType + <*> getT "clientToken" + <*> resourceTagSink + <*> getF "hypervisor" hypervisor + <*> networkInterfaceSink + <*> elementM "iamInstanceProfile" ( + iamInstanceProfile + <$> getT "arn" + <*> getT "id" + ) + <*> getF "ebsOptimized" textToBool + +instanceStateSink :: MonadThrow m + => Text -> GLSink Event m InstanceState +instanceStateSink label = element label $ + codeToState + <$> getF "code" textToInt + <* getT "name" + +networkInterfaceSink :: MonadThrow m + => GLSink Event m [InstanceNetworkInterface] +networkInterfaceSink = itemsSet "networkInterfaceSet" $ + instanceNetworkInterface + <$> getT "networkInterfaceId" + <*> getT "subnetId" + <*> getT "vpcId" + <*> getM "description" orEmpty + <*> getT "ownerId" + <*> getT "status" + <*> getT "privateIpAddress" + <*> getMT "privateDnsName" + <*> getF "sourceDestCheck" textToBool + <*> groupSetSink + <*> element "attachment" ( + networkInterfaceAttachment + <$> getT "attachmentId" + <*> getF "deviceIndex" textToInt + <*> getT "status" + <*> getF "attachTime" textToTime + <*> getF "deleteOnTermination" textToBool + ) + <*> niAssociationSink + <*> itemsSet "privateIpAddressesSet" ( + instancePrivateIpAddress + <$> getT "privateIpAddress" + <*> getF "primary" textToBool + <*> niAssociationSink + ) + +niAssociationSink :: MonadThrow m + => GLSink Event m (Maybe NetworkInterfaceAssociation) +niAssociationSink = elementM "association" $ + networkInterfaceAssociation + <$> getT "publicIp" + <*> getT "ipOwnerId" + +------------------------------------------------------------ +-- DescribeInstanceStatus +------------------------------------------------------------ +-- | raise 'ResponseParserException'('NextToken' token) +describeInstanceStatus + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ InstanceIds + -> Bool -- ^ is all instance? 'False': running instance only. + -> [Filter] -- ^ Filters + -> Maybe Text -- ^ next token + -> EC2 m (Source m InstanceStatus) +describeInstanceStatus instanceIds isAll filters token = + ec2QuerySource' "DescribeInstanceStatus" params token instanceStatusSet + where + params = + [ ArrayParams "InstanceId" instanceIds + , ValueParam "IncludeAllInstances" $ boolToText isAll + , FilterParams filters + ] + +instanceStatusSet :: MonadThrow m + => GLConduit Event m InstanceStatus +instanceStatusSet = do + itemConduit "instanceStatusSet" $ + instanceStatus + <$> getT "instanceId" + <*> getT "availabilityZone" + <*> itemsSet "eventsSet" ( + instanceStatusEvent + <$> getF "code" instanceStatusEventCode + <*> getT "description" + <*> getM "notBefore" (textToTime <$>) + <*> getM "notAfter" (textToTime <$>) + ) + <*> instanceStateSink "instanceState" + <*> instanceStatusTypeSink "systemStatus" + <*> instanceStatusTypeSink "instanceStatus" + +instanceStatusTypeSink :: MonadThrow m + => Text -> GLSink Event m InstanceStatusType +instanceStatusTypeSink name = element name $ + instanceStatusType + <$> getF "status" instanceStatusTypeStatus + <*> itemsSet "details" ( + instanceStatusDetail + <$> getT "name" + <*> getT "status" + <*> getM "impairedSince" (textToTime <$>) + ) + +------------------------------------------------------------ +-- StartInstances +------------------------------------------------------------ +startInstances + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ InstanceIds + -> EC2 m (Source m InstanceStateChange) +startInstances instanceIds = + ec2QuerySource "StartInstances" params instanceStateChangeSet + where + params = [ArrayParams "InstanceId" instanceIds] + +instanceStateChangeSet + :: (MonadResource m, MonadBaseControl IO m) + => Conduit Event m InstanceStateChange +instanceStateChangeSet = itemConduit "instancesSet" $ do + instanceStateChange + <$> getT "instanceId" + <*> instanceStateSink "currentState" + <*> instanceStateSink "previousState" + +------------------------------------------------------------ +-- StopInstances +------------------------------------------------------------ +stopInstances + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ InstanceIds + -> Bool -- ^ Force + -> EC2 m (Source m InstanceStateChange) +stopInstances instanceIds force = + ec2QuerySource "StopInstances" params instanceStateChangeSet + where + params = + [ ArrayParams "InstanceId" instanceIds + , ValueParam "Force" $ boolToText force] + +------------------------------------------------------------ +-- RebootInstances +------------------------------------------------------------ +rebootInstances + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ InstanceIds + -> EC2 m Bool +rebootInstances instanceIds = + ec2Query "RebootInstances" params $ getF "return" textToBool + where + params = [ArrayParams "InstanceId" instanceIds] + +------------------------------------------------------------ +-- TerminateInstances +------------------------------------------------------------ +terminateInstances + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ InstanceIds + -> EC2 m (Source m InstanceStateChange) +terminateInstances instanceIds = + ec2QuerySource "TerminateInstances" params + instanceStateChangeSet + where + params = [ArrayParams "InstanceId" instanceIds] + +------------------------------------------------------------ +-- RunInstances +------------------------------------------------------------ +-- | 'RunInstancesParam' is genereted with 'defaultRunInstancesParam' +runInstances + :: (MonadResource m, MonadBaseControl IO m) + => RunInstancesParam + -> EC2 m Reservation +runInstances param = + ec2Query "RunInstances" params reservationSink + where + mk name = maybe [] (\a -> [ValueParam name a]) + params = + [ ValueParam "ImageId" $ riImageId param + , ValueParam "MinCount" $ toText $ riMinCount param + , ValueParam "MaxCount" $ toText $ riMaxCount param + , ArrayParams "SecurityGroupId" $ riSecurityGroupIds param + , ArrayParams "SecurityGroup" $ riSecurityGroups param + , blockDeviceMappingParams $ riBlockDeviceMappings param + ] ++ (uncurry mk =<< + [ ("KeyName", riKeyName param) , ("UserData", bsToText <$> riUserData param) + , ("InstanceType", riInstanceType param) + , ("Placement.AvailabilityZone", + riAvailabilityZone param) + , ("Placement.GroupName", riPlacementGroup param) + , ("Placement.Tenancy", riTenancy param) + , ("KernelId", riKernelId param) + , ("RamdiskId", riRamdiskId param) + , ("Monitoring.Enabled", + boolToText <$> riMonitoringEnabled param) + , ("SubnetId", riSubnetId param) + , ("DisableApiTermination", + boolToText <$> riDisableApiTermination param) + , ("InstanceInitiatedShutdownBehavior", + sbToText <$> riShutdownBehavior param) + , ("ClientToken", riClientToken param) + , ("IamInstanceProfile.Arn", + iipArn <$> riIamInstanceProfile param) + , ("IamInstanceProfile.Name", + iipId <$> riIamInstanceProfile param) + , ("EbsOptimized", boolToText <$> riEbsOptimized param) + ]) + +data RunInstancesParam = RunInstancesParam + { riImageId :: Text -- ^ Required + , riMinCount :: Int -- ^ Required + , riMaxCount :: Int -- ^ Required + , riKeyName :: Maybe Text + , riSecurityGroupIds :: [Text] + -- ^ SecurityGroupIds (Required for VPC; optional for EC2) + , riSecurityGroups :: [Text] + -- ^ SecurityGroups (Only for EC2; either id or name is accepted) + , riUserData :: Maybe ByteString + -- ^ UserData (Base64-encoded MIME user data) + , riInstanceType :: Maybe Text + , riAvailabilityZone :: Maybe Text + , riPlacementGroup :: Maybe Text + , riTenancy :: Maybe Text + , riKernelId :: Maybe Text + , riRamdiskId :: Maybe Text + , riBlockDeviceMappings :: [BlockDeviceMappingParam] + , riMonitoringEnabled :: Maybe Bool + , riSubnetId :: Maybe Text + , riDisableApiTermination :: Maybe Bool + , riShutdownBehavior :: Maybe ShutdownBehavior + , riPrivateIpAddresses :: [Text] -- ^ XXX: not implemented + , riClientToken :: Maybe Text + , riNetworkInterface :: [NetworkInterfaceParam] -- ^ XXX: not implemented + , riIamInstanceProfile :: Maybe IamInstanceProfile + , riEbsOptimized :: Maybe Bool + } + deriving (Show) + +-- | RunInstances parameter utility +defaultRunInstancesParam + :: Text -- ^ ImageId + -> Int -- ^ MinCount + -> Int -- ^ MaxCount + -> RunInstancesParam +defaultRunInstancesParam iid minCount maxCount = RunInstancesParam + { riImageId = iid + , riMinCount = minCount + , riMaxCount = maxCount + , riKeyName = Nothing + , riSecurityGroupIds = [] + , riSecurityGroups = [] + , riUserData = Nothing + , riInstanceType = Nothing + , riAvailabilityZone = Nothing + , riPlacementGroup = Nothing + , riTenancy = Nothing + , riKernelId = Nothing + , riRamdiskId = Nothing + , riBlockDeviceMappings = [] + , riMonitoringEnabled = Nothing + , riSubnetId = Nothing + , riDisableApiTermination = Nothing + , riShutdownBehavior = Nothing + , riPrivateIpAddresses = [] + , riClientToken = Nothing + , riNetworkInterface = [] + , riIamInstanceProfile = Nothing + , riEbsOptimized = Nothing + } + +sbToText :: ShutdownBehavior -> Text +sbToText SBStop = "stop" +sbToText SBTerminate = "terminate" + +------------------------------------------------------------ +-- GetConsoleOutput +------------------------------------------------------------ +getConsoleOutput + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ InstanceId + -> EC2 m ConsoleOutput +getConsoleOutput iid = + ec2Query "GetConsoleOutput" [ValueParam "InstanceId" iid] $ + consoleOutput + <$> getT "instanceId" + <*> getF "timestamp" textToTime + <*> getT "output" + +------------------------------------------------------------ +-- GetPasswordData +------------------------------------------------------------ +getPasswordData + :: (MonadResource m, MonadBaseControl IO m) + => Text -- ^ InstanceId + -> EC2 m PasswordData +getPasswordData iid = + ec2Query "GetPasswordData" [ValueParam "InstanceId" iid] $ + passwordData + <$> getT "instanceId" + <*> getF "timestamp" textToTime + <*> getT "passwordData" diff --git a/AWS/EC2/Params.hs b/AWS/EC2/Params.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Params.hs @@ -0,0 +1,38 @@ +module AWS.EC2.Params where + +import Data.Text (Text) + +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) + +data EbsSource + = EbsSnapshotId Text + | EbsVolumeSize Int + deriving (Show) + +data ShutdownBehavior = SBStop | SBTerminate 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) diff --git a/AWS/EC2/Parser.hs b/AWS/EC2/Parser.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Parser.hs @@ -0,0 +1,34 @@ +module AWS.EC2.Parser + ( module AWS.EC2.Parser.Internal + , resourceTagSink + , productCodeSink + , stateReasonSink + ) where + +import Control.Applicative +import Data.Conduit +import Data.XML.Types (Event) + +import AWS.EC2.Types +import AWS.EC2.Parser.Internal + +resourceTagSink :: MonadThrow m + => GLSink Event m [ResourceTag] +resourceTagSink = itemsSet "tagSet" $ + resourceTag + <$> getT "key" + <*> getMT "value" + +productCodeSink :: MonadThrow m + => GLSink Event m [ProductCode] +productCodeSink = itemsSet "productCodes" $ + productCode + <$> getT "productCode" + <*> getF "type" productCodeType + +stateReasonSink :: MonadThrow m + => GLSink Event m (Maybe StateReason) +stateReasonSink = elementM "stateReason" $ + stateReason + <$> getT "code" + <*> getT "message" diff --git a/AWS/EC2/Parser/Internal.hs b/AWS/EC2/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Parser/Internal.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +module AWS.EC2.Parser.Internal where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Lazy.Char8 () + +import Data.XML.Types (Event(..), Name(..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Conduit +import qualified Data.Conduit.List as CL +import qualified Text.XML.Stream.Parse as XML +import Control.Applicative +import Data.Monoid ((<>)) + +apiVersion :: ByteString +apiVersion = "2012-08-15" + +itemConduit :: MonadThrow m + => Text + -> GLSink Event m o + -> GLConduit Event m o +itemConduit tag inner = do + maybe (()) id <$> elementM tag (items inner) + where + items :: MonadThrow m + => Pipe Event Event o u m o + -> Pipe Event Event o u m () + items p = awaitWhile isTag >>= maybe (return ()) (\e -> do + leftover e + if isBeginTagName "item" e + then do + element "item" $ p >>= yield + items p + else return () + ) + +itemsSet :: MonadThrow m + => Text + -> GLSink Event m o + -> GLSink Event m [o] +itemsSet tag inner = itemConduit tag inner >+> CL.consume + +isTag :: Event -> Bool +isTag (EventBeginElement _ _) =True +isTag (EventEndElement _) =True +isTag _ = False + +isBeginTagName :: Text -> Event -> Bool +isBeginTagName name (EventBeginElement n _) + | n == ec2Name name = True + | otherwise = False +isBeginTagName _ _ = False + +awaitWhile :: Monad m + => (i -> Bool) + -> Pipe l i o u m (Maybe i) +awaitWhile f = await >>= g + where + g Nothing = return Nothing + g (Just a) + | f a = return $ Just a + | otherwise = awaitWhile f + +getF :: MonadThrow m + => Text + -> (Text -> b) + -> Pipe Event Event o u m b +getF name f = tagContentF name >>= return . f + +getT :: MonadThrow m + => Text + -> Pipe Event Event o u m Text +getT name = getF name id + +getM :: MonadThrow m + => Text + -> (Maybe Text -> b) + -> Pipe Event Event o u m b +getM name f = tagContent name >>= return . f + +getMT :: MonadThrow m + => Text + -> Pipe Event Event o u m (Maybe Text) +getMT name = getM name id + +elementM :: MonadThrow m + => Text + -> Pipe Event Event o u m a + -> Pipe Event Event o u m (Maybe a) +elementM name inner = XML.tagNoAttr (ec2Name name) inner + +element :: MonadThrow m + => Text + -> Pipe Event Event o u m a + -> Pipe Event Event o u m a +element name inner = XML.force "parse error" $ elementM name inner + +tagContent :: MonadThrow m + => Text + -> GLSink Event m (Maybe Text) +tagContent name = XML.tagNoAttr (ec2Name name) XML.content + +tagContentF :: MonadThrow m + => Text + -> GLSink Event m Text +tagContentF = XML.force "parse error" . tagContent + +ec2Name :: Text -> Name +ec2Name name = Name + { nameLocalName = name + , nameNamespace = + Just $ "http://ec2.amazonaws.com/doc/" <> T.pack (BSC.unpack apiVersion) <> "/" + , namePrefix = Nothing + } diff --git a/AWS/EC2/Query.hs b/AWS/EC2/Query.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Query.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE FlexibleContexts, RankNTypes #-} + +module AWS.EC2.Query + ( ec2Query + , ec2QuerySource + , ec2QuerySource' + , ec2Request + , QueryParam(..) + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy.Char8 () +import qualified Data.ByteString.Char8 as BSC + +import Data.Monoid +import Data.XML.Types (Event(..)) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Network.HTTP.Conduit as HTTP +import qualified Text.XML.Stream.Parse as XmlP +import Data.Time (UTCTime, formatTime, getCurrentTime) +import System.Locale (defaultTimeLocale, iso8601DateFormat) +import qualified Data.Map as Map +import Data.Map (Map) +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.Trans.Class (lift) +import qualified Control.Monad.State as ST +import Control.Exception.Lifted as E +import Data.Text (Text) + +import AWS.EC2.Types +import AWS.Types +import AWS.Util +import AWS.EC2.Parser +import AWS.EC2.Class +import AWS.Credential + +{- Debug +import Debug.Trace +import qualified Data.Conduit.Binary as CB +--} + +data QueryParam + = ArrayParams Text [Text] + | FilterParams [Filter] + | ValueParam Text Text + | StructArrayParams Text [[(Text, Text)]] + deriving (Show) + +queryHeader :: ByteString -> UTCTime -> Credential -> [(ByteString, ByteString)] +queryHeader action time cred = + [ ("Action", action) + , ("Version", apiVersion) + , ("SignatureVersion", "2") + , ("SignatureMethod", "HmacSHA256") + , ("Timestamp", H.urlEncode True $ awsTimeFormat time) + , ("AWSAccessKeyId", accessKey cred) + ] + +mkUrl :: Endpoint end + => end + -> Credential + -> UTCTime + -> ByteString + -> [QueryParam] + -> ByteString +mkUrl ep cred time action params = mconcat + [ "https://" + , endpointStr ep + , "/?" + , qparam + , "&Signature=" + , signature ep (secretAccessKey cred) qparam + ] + where + qheader = Map.fromList $ queryHeader action time cred + qparam = queryStr $ Map.unions (qheader : map toArrayParams params) + +toArrayParams :: QueryParam -> Map ByteString ByteString +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 + where + f1 (n, (key, vals)) = (filt n <> ".Name", textToBS key) : + [ (filt n <> ".Value." <> bsShow i, textToBS param) + | (i, param) <- zip ([1..]::[Int]) vals + ] + filt n = "Filter." <> bsShow n +toArrayParams (ValueParam k v) = + Map.singleton (textToBS k) (textToBS v) +toArrayParams (StructArrayParams name vss) = Map.fromList l + where + bsName = textToBS name + struct n (k, v) = (n <> "." <> textToBS k, textToBS v) + l = mconcat + [ map (struct (bsName <> "." <> bsShow i)) kvs + | (i, kvs) <- zip ([1..]::[Int]) vss + ] + +queryStr :: Map ByteString ByteString -> ByteString +queryStr = BS.intercalate "&" . Map.foldrWithKey' concatWithEqual [] + where + concatWithEqual key val acc = key <> "=" <> val : acc + +awsTimeFormat :: UTCTime -> ByteString +awsTimeFormat = BSC.pack . formatTime defaultTimeLocale (iso8601DateFormat $ Just "%XZ") + +signature :: Endpoint end + => end -> SecretAccessKey -> ByteString -> ByteString +signature ep secret query = urlstr + where + stringToSign = "GET\n" <> endpointStr ep <> "\n/\n" <> query + signedStr = toS . SHA.bytestringDigest $ SHA.hmacSha256 (toL secret) (toL stringToSign) + urlstr = H.urlEncode True . BASE.encode $ signedStr + +sinkRequestId :: MonadThrow m + => GLSink Event m Text +sinkRequestId = do + await -- EventBeginDocument + await -- EventBeginElement DescribeImagesResponse + tagContentF "requestId" + +ec2Request + :: (MonadResource m, MonadBaseControl IO m) + => EC2Context + -> ByteString + -> [QueryParam] + -> m (ResumableSource m ByteString) +ec2Request 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 + +ec2Query + :: (MonadResource m, MonadBaseControl IO m) + => ByteString + -> [QueryParam] + -> GLSink Event m o + -> EC2 m o +ec2Query action params sink = do + src <- ec2QuerySource action params $ sink >>= yield + lift (src $$ CL.head) >>= maybe (fail "parse error") return + +ec2QuerySource + :: (MonadResource m, MonadBaseControl IO m) + => ByteString + -> [QueryParam] + -> Conduit Event m o + -> EC2 m (Source m o) +ec2QuerySource action params cond = do + ec2QuerySource' action params Nothing cond + +ec2QuerySource' + :: (MonadResource m, MonadBaseControl IO m) + => ByteString + -> [QueryParam] + -> Maybe Text + -> Conduit Event m o + -> EC2 m (Source m o) +ec2QuerySource' action params token cond = do + ctx <- ST.get + (src1, rid) <- lift $ do + response <- ec2Request 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} + lift $ do + (src2, _) <- unwrapResumable src1 + return $ src2 $= (cond >> nextToken) + where + params' = maybe params + (\t -> ValueParam "NextToken" t:params) token + + nextToken + :: (MonadResource m, MonadBaseControl IO m) + => Conduit Event m o + nextToken = do + mt <- getMT "nextToken" + case mt of + Nothing -> return () + Just t -> E.throw $ NextToken t diff --git a/AWS/EC2/Region.hs b/AWS/EC2/Region.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Region.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} + +module AWS.EC2.Region + ( describeRegions + ) 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 + +describeRegions + :: (MonadResource m, MonadBaseControl IO m) + => [Text] -- ^ RegionNames + -> [Filter] -- ^ Filters + -> EC2 m (Source m Region) +describeRegions regions filters = + ec2QuerySource "DescribeRegions" params regionInfoConduit + where + params = + [ ArrayParams "RegionName" regions + , FilterParams filters + ] + regionInfoConduit :: MonadThrow m + => GLConduit Event m Region + regionInfoConduit = itemConduit "regionInfo" $ + region + <$> getT "regionName" + <*> getT "regionEndpoint" diff --git a/AWS/EC2/Tag.hs b/AWS/EC2/Tag.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Tag.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} + +module AWS.EC2.Tag + ( describeTags + ) where + +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 + +describeTags + :: (MonadResource m, MonadBaseControl IO m) + => [Filter] -- ^ Filters + -> EC2 m (Source m Tag) +describeTags filters = + ec2QuerySource "DescribeTags" params $ itemConduit "tagSet" $ + tag + <$> getT "resourceId" + <*> getT "resourceType" + <*> getT "key" + <*> getMT "value" + where + params = [FilterParams filters] diff --git a/AWS/EC2/Types.hs b/AWS/EC2/Types.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Types.hs @@ -0,0 +1,836 @@ +module AWS.EC2.Types where + +import Data.Default (Default(..)) +import Data.Text (Text) +import Data.Time (UTCTime) + +import AWS.Util + +type Filter = (Text, [Text]) + +data Image = Image + { imageId :: Text + , imageLocation :: Text + , imageImageState :: ImageState + , imageOwnerId :: Text + , isPublic :: Bool + , imageProductCodes :: [ProductCode] + , imageArchitecture :: Text + , imageImageType :: ImageType + , kernelId :: Maybe Text + , ramdiskId :: Maybe Text + , imagePlatform :: Platform + , imageStateReason :: Maybe StateReason + , imageOwnerAlias :: Maybe Text + , imageName :: Text + , imageDescription :: Text + , imageRootDeviceType :: RootDeviceType + , imageRootDeviceName :: Maybe Text + , blockDeviceMappings :: [BlockDeviceMapping] + , imageVirtualizationType :: VirtualizationType + , imageTagSet :: [ResourceTag] + , imageHypervisor :: Hypervisor + } + 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 + | ImageFailed + deriving (Show) + +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 + } + deriving (Show) + +productCode :: Text -> ProductCodeType -> ProductCode +productCode c t = ProductCode + { pcCode = c + , pcType = t + } + +data ProductCodeType = Devpay + | Marketplace + deriving (Show) + +productCodeType :: Text -> ProductCodeType +productCodeType t + | t == "marketplace" = Marketplace + | t == "devpay" = Devpay + | otherwise = err "product code type" t + +data ImageType = Machine + | Kernel + | RamDisk + deriving (Show) + +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) + +platform :: Maybe Text -> Platform +platform Nothing = Other +platform (Just t) + | t == "windows" = Windows + | otherwise = Other + +data StateReason = StateReason + { stateReasonCode :: Text + , stateReasonMessage :: Text + } + deriving (Show) + +stateReason :: Text -> Text -> StateReason +stateReason c m = + StateReason + { stateReasonCode = c + , stateReasonMessage = m + } + +data RootDeviceType = EBS + | InstanceStore + deriving (Show) + +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 + , ebs :: Maybe EbsBlockDevice + } + 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 + , ebsDeleteOnTermination :: Bool + , ebsVolumeType :: VolumeType + } + 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) + +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 + +data VirtualizationType = Paravirtual + | HVM + deriving (Show) + +virtualizationType :: Text -> VirtualizationType +virtualizationType t + | t == "paravirtual" = Paravirtual + | t == "hvm" = HVM + | otherwise = err "virtualization type" t + +data ResourceTag = ResourceTag + { resourceKey :: Text + , resourceValue :: Maybe Text + } + deriving (Show) + +resourceTag :: Text -> Maybe Text -> ResourceTag +resourceTag k v = + ResourceTag + { resourceKey = k + , resourceValue = v + } + +data Hypervisor = OVM + | Xen + deriving (Show) + +hypervisor :: Text -> Hypervisor +hypervisor t + | t == "xen" = Xen + | t == "ovm" = OVM + | otherwise = err "hypervisor" t + +{- DescribeRegions -} +data Region = Region + { regionName :: Text + , regionEndpoint :: Text + } + deriving (Show) + +region :: Text -> Text -> Region +region name rep = Region + { regionName = name + , regionEndpoint = rep + } + +{- DescribeAvailabilityZones -} +data AvailabilityZone = AvailabilityZone + { zoneName :: Text + , zoneState :: Text + , zoneRegionName :: Text + , messageSet :: [AvailabilityZoneMessage] + } + deriving (Show) + +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 + , groupSet :: [Group] + , instanceSet :: [Instance] + , requesterId :: Maybe Text + } + 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 + , instanceState :: InstanceState + , privateDnsName :: Text + , dnsName :: Text + , reason :: Text + , keyName :: Maybe Text + , amiLaunchIndex :: Text + , instanceProductCodes :: [ProductCode] + , instanceType :: Text + , launchTime :: UTCTime + , instancePlacement :: Placement + , instanceKernelId :: Maybe Text + , instanceRamdiskId :: Maybe Text + , instancePlatform :: Maybe Text + , instanceMonitoring :: InstanceMonitoringState + , subnetId :: Maybe Text + , vpcId :: Maybe Text + , privateIpAddress :: Maybe Text + , ipAddress :: Maybe Text + , sourceDestCheck :: Maybe Bool + , vpcGroupSet :: [Group] + , instanceStateReason :: Maybe StateReason + , instanceArchitecture :: Architecture + , instanceRootDeviceType :: RootDeviceType + , instanceRootDeviceName :: Maybe Text + , instanceBlockDeviceMappings :: [InstanceBlockDeviceMapping] + , instanceInstanceLifecycle :: InstanceLifecycle + , spotInstanceRequestId :: Maybe Text + , instanceVirtualizationType :: VirtualizationType + , clientToken :: Text + , instanceTagSet :: [ResourceTag] + , instanceHypervisor :: Hypervisor + , instanceNetworkInterfaceSet :: [InstanceNetworkInterface] + , instanceIamInstanceProfile :: Maybe IamInstanceProfile + , ebsOptimized :: Bool -- default: false + } + 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 + , isEventsSet :: [InstanceStatusEvent] + , isInstanceState :: InstanceState + , isSystemStatus :: InstanceStatusType + , isInstanceStatus :: InstanceStatusType + } + 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 + , iseNotBefore :: Maybe UTCTime + , iseNotAfter :: Maybe UTCTime + } + 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 + | SystemReboot + | InstanceRetirement + deriving (Show) + +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] + } + deriving (Show) + +instanceStatusType :: InstanceStatusTypeStatus + -> [InstanceStatusDetail] -> InstanceStatusType +instanceStatusType status details = InstanceStatusType + { isdStatus = status + , isdDetails = details + } + +data InstanceStatusTypeStatus + = InstanceStatusOK + | InstanceStatusImpaired + | InstanceStatusInsufficientData + | InstanceStatusNotApplicable + deriving (Show) + +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 + , isddImpairedSince :: Maybe UTCTime + } + 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 + +data Group = Group + { groupId :: Text + , groupName :: Text + } + deriving (Show) + +group :: Text -> Text -> Group +group i n = Group + { groupId = i + , groupName = n + } + +data InstanceState + = Pending + | Running + | ShuttingDown + | Terminated + | Stopping + | Stopped + deriving (Show) + +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 -> error "invalid state code" + Just st -> st + +data Placement = Placement + { placementAvailabilityZone :: Text + , placementGroupName :: Text + , tenancy :: Text + } + deriving (Show) + +placement :: Text -> Text -> Text -> Placement +placement zone gname ten = Placement + { placementAvailabilityZone = zone + , placementGroupName = gname + , tenancy = ten + } + +data InstanceMonitoringState + = MonitoringDisabled + | MonitoringEnabled + | MonitoringPending + deriving (Show) + +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) + +architecture :: Text -> Architecture +architecture t + | t == "i386" = I386 + | t == "x86_64" = X86_64 + | otherwise = err "architecture" t + +data InstanceBlockDeviceMapping = InstanceBlockDeviceMapping + { instanceDeviceName :: Text + , instanceEbs :: InstanceEbsBlockDevice + } + deriving (Show) + +instanceBlockDeviceMapping + :: Text -> InstanceEbsBlockDevice + -> InstanceBlockDeviceMapping +instanceBlockDeviceMapping devname iebs = + InstanceBlockDeviceMapping + { instanceDeviceName = devname + , instanceEbs = iebs + } + +data InstanceEbsBlockDevice = InstanceEbsBlockDevice + { instanceEbsVolumeId :: Text + , instanceEbsState :: VolumeState + , instanceEbsAttachTime :: UTCTime + , instanceEbsDeleteOnTermination :: Bool + } + deriving (Show) + +instanceEbsBlockDevice + :: Text -> VolumeState -> UTCTime -> Bool + -> InstanceEbsBlockDevice +instanceEbsBlockDevice vid vst atime dot = + InstanceEbsBlockDevice + { instanceEbsVolumeId = vid + , instanceEbsState = vst + , instanceEbsAttachTime = atime + , instanceEbsDeleteOnTermination = dot + } + +data VolumeState + = VolumeAttaching + | VolumeAttached + | VolumeDetaching + | VolumeDetached + deriving (Show) + +volumeState :: Text -> VolumeState +volumeState t + | t == "attached" = VolumeAttached + | t == "attaching" = VolumeAttaching + | t == "detaching" = VolumeDetaching + | t == "detached" = VolumeDetached + | otherwise = err "volume state" t + +data InstanceLifecycle = LifecycleSpot | LifecycleNone + deriving (Show) + +instanceLifecycle :: Maybe Text -> InstanceLifecycle +instanceLifecycle Nothing = LifecycleNone +instanceLifecycle (Just t) + | t == "spot" = LifecycleSpot + | otherwise = err "lifecycle" t + +data InstanceNetworkInterface = InstanceNetworkInterface + { instanceNetworkInterfaceId :: Text + , iniSubnetId :: Text + , iniVpcId :: Text + , iniDescription :: Text + , iniOwnerId :: Text + , iniStatus :: Text + , iniPrivateIpAddress :: Text + , iniPrivateDnsName :: Maybe Text + , iniSourceDestCheck :: Bool + , iniGroupSet :: [Group] + , iniAttachment :: NetworkInterfaceAttachment + , iniAssociation :: Maybe NetworkInterfaceAssociation + , iniPrivateIpAddressSet :: [InstancePrivateIpAddress] + } + 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 + , niatStatus :: Text + , niatAttachTime :: UTCTime + , niatDeleteOnTermination :: Bool + } + 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 + , iAssociation :: Maybe NetworkInterfaceAssociation + } + 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 Address = Address + { addrPublicIp :: Text + , addrAllocationId :: Maybe Text + , addrDomain :: AddressDomain + , addrInstanceId :: Maybe Text + , addrAssociationId :: Maybe Text + , addrNetworkInterfaceId :: Maybe Text + , addrNetworkInterfaceOwnerId :: Maybe Text + , addrPrivateIpAddress :: Maybe Text + } + 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) + +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 + , alaAllocationId :: Maybe Text + } + 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) + +ec2Return :: Text -> EC2Return +ec2Return t + | t == "true" = EC2Success + | otherwise = EC2Error t + +data Tag = Tag + { tagResourceId :: Text + , tagResourceType :: Text + , tagKey :: Text + , tagValue :: Maybe Text + } + 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 + , iscPreviousState :: InstanceState + } + 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. + , coOutput :: Text + } + 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. + , pdPasswordData :: Text + } + deriving (Show) + +passwordData :: Text -> UTCTime -> Text -> PasswordData +passwordData iid time out = PasswordData + { pdInstanceId = iid + , pdTimestamp = time + , pdPasswordData = out + } diff --git a/AWS/EC2/Utils.hs b/AWS/EC2/Utils.hs new file mode 100644 --- /dev/null +++ b/AWS/EC2/Utils.hs @@ -0,0 +1,39 @@ +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) + ] diff --git a/AWS/Types.hs b/AWS/Types.hs new file mode 100644 --- /dev/null +++ b/AWS/Types.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +module AWS.Types + ( Endpoint (..) + , EC2Endpoint (..) + ) where + +import Data.ByteString (ByteString) +import Data.ByteString.Char8 () + +class Endpoint a where + endpointStr :: a -> ByteString + +data EC2Endpoint = UsEast1 + | ApNortheast1 + +instance Endpoint EC2Endpoint where + endpointStr UsEast1 = "ec2.us-east-1.amazonaws.com" + endpointStr ApNortheast1 = "ec2.ap-northeast-1.amazonaws.com" diff --git a/AWS/Util.hs b/AWS/Util.hs new file mode 100644 --- /dev/null +++ b/AWS/Util.hs @@ -0,0 +1,57 @@ +module AWS.Util where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as TR +import Data.Time (UTCTime) +import qualified Data.Time as Time +import System.Locale (defaultTimeLocale) + +toS :: BSL.ByteString -> ByteString +toS = BS.concat . BSL.toChunks + +toL :: ByteString -> BSL.ByteString +toL = BSL.fromChunks . (:[]) + +bsShow :: Show a => a -> ByteString +bsShow = BSC.pack . show + +err :: String -> Text -> a +err v m = error $ "unknown " ++ v ++ ": " ++ T.unpack m + +textToBool :: Text -> Bool +textToBool a + | a == "true" = True + | a == "false" = False + | otherwise = err "value" a + +textToInt :: Integral a => Text -> a +textToInt t = either + (const $ error "not decimal") + fst + (TR.decimal t) + +textToTime :: Text -> UTCTime +textToTime = Time.readTime defaultTimeLocale fmt . T.unpack + where + fmt = "%FT%T.000Z" + +orEmpty :: Maybe Text -> Text +orEmpty = maybe "" id + +boolToText :: Bool -> Text +boolToText True = "true" +boolToText False = "false" + +toText :: Show a => a -> Text +toText = T.pack . show + +bsToText :: ByteString -> Text +bsToText = T.pack . BSC.unpack + +textToBS :: Text -> ByteString +textToBS = BSC.pack . T.unpack diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, AWS SDK for Haskell Developers + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Yusuke Nomura nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aws-sdk.cabal b/aws-sdk.cabal new file mode 100644 --- /dev/null +++ b/aws-sdk.cabal @@ -0,0 +1,74 @@ +name: aws-sdk +version: 0.1.0.0 +synopsis: AWS SDK for Haskell +description: An AWS(Amazon Web Services) liblary for Haskell. +license: BSD3 +license-file: LICENSE +author: Yusuke Nomura +maintainer: Yusuke Nomura +homepage: https://worksap-ate.github.com/aws-sdk +copyright: AWS SDK for Haskell Developers +category: Cloud, AWS +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: AWS + , AWS.Types + , AWS.EC2 + , AWS.EC2.Types + , AWS.EC2.Params + other-modules: AWS.Util + , AWS.Credential + , AWS.EC2.Address + , AWS.EC2.AvailabilityZone + , AWS.EC2.Image + , AWS.EC2.Instance + , 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 + ghc-options: -Wall + -fno-warn-unused-do-bind + extensions: OverloadedStrings + build-depends: base ==4.5.* + , containers + , SHA + , base64-bytestring >= 1.0.0.0 + , bytestring + , http-types + , conduit + , transformers + , time + , old-locale + , http-conduit + , data-default + , xml-conduit + , xml-types + , text + , monad-control + , safe + , simple-config >= 1.1.0 + , parsec3 + , mtl + , lifted-base + , transformers-base + +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: tests + ghc-options: -Wall + + build-depends: base + , hspec + , QuickCheck + +source-repository head + type: git + location: git://github.com/worksap-ate/aws-sdk.git + diff --git a/tests/main.hs b/tests/main.hs new file mode 100644 --- /dev/null +++ b/tests/main.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main where + +import Test.Hspec (hspec) + +import PropExample +import SpecExample + +main :: IO () +main = do + propTest + specTest + +specTest :: IO () +specTest = hspec normalSpecs + +propTest :: IO () +propTest = hspec propSpecs