aws-sdk 0.2.0.0 → 0.3.0.0

raw patch · 27 files changed

+827/−414 lines, 27 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• AWS.hs +8/−4
• AWS/Class.hs +101/−0
• AWS/EC2.hs +20/−9
• AWS/EC2/Address.hs +1/−1
• AWS/EC2/AvailabilityZone.hs +1/−1
• AWS/EC2/Class.hs +0/−93
• AWS/EC2/Image.hs +1/−1
• AWS/EC2/Instance.hs +1/−1
• AWS/EC2/Internal.hs +26/−0
• AWS/EC2/KeyPair.hs +1/−1
• AWS/EC2/Parser.hs +2/−2
• AWS/EC2/Parser/Internal.hs +0/−117
• AWS/EC2/Query.hs +14/−154
• AWS/EC2/Region.hs +1/−1
• AWS/EC2/SecurityGroup.hs +1/−1
• AWS/EC2/Snapshot.hs +1/−1
• AWS/EC2/Tag.hs +1/−1
• AWS/EC2/Types.hs +2/−3
• AWS/EC2/Util.hs +51/−0
• AWS/EC2/Utils.hs +0/−2
• AWS/EC2/Volume.hs +1/−1
• AWS/Lib/Parser.hs +124/−0
• AWS/Lib/Query.hs +165/−0
• AWS/RDS.hs +202/−0
• AWS/RDS/Types.hs +93/−0
• AWS/Types.hs +1/−16
• aws-sdk.cabal +8/−4

@@ -17,14 +17,14 @@ -- >  -- > import AWS -- > import AWS.EC2+-- > import qualified AWS.EC2.Util as Util -- >  -- > main :: IO () -- > main = do -- >     cred <- loadCredential--- >     doc <- runResourceT $ do--- >         runEC2 cred $ do--- >             response <- describeInstances [] []--- >             lift $ response $$ CL.consume+-- >     doc <- runResourceT $+-- >         runEC2 cred $+-- >             Util.asList $ describeInstances [] [] -- >     print doc -- >     putStr "Length: " -- >     print $ length doc@@ -33,6 +33,10 @@     ( -- * Credentials       Credential     , loadCredential+      -- * Environment+    , AWS+    , AWSException(..)     ) where  import AWS.Credential+import AWS.Class

@@ -0,0 +1,101 @@+{-# LANGUAGE GeneralizedNewtypeDeriving+ , TypeFamilies+ , FlexibleInstances+ , MultiParamTypeClasses+ , UndecidableInstances+ , DeriveDataTypeable+ #-}++module AWS.Class+    ( AWS+    , runAWS+    , AWSException(..)+    , AWSContext(..)+    ) where++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, liftIO)+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 Data.ByteString (ByteString)+import Data.ByteString.Char8 ()++import AWS.Credential++data AWSException+    = ClientError+        { errorCode :: Text+        , errorMessage :: Text+        , errorRequestId :: Text+        } -- ^ This error is caused by client requests.+    | NextToken Text -- ^ This response has next token.+  deriving (Show, Typeable)++instance Exception AWSException++data AWSContext = AWSContext+    { manager :: HTTP.Manager+    , endpoint :: ByteString+    , lastRequestId :: Maybe Text+    }++newtype AWS context m a = AWST+    { runAWST :: StateT context (ReaderT Credential m) a+    } deriving+    ( Monad+    , Applicative+    , Functor+    , MonadIO+    , MonadState context+    , MonadReader Credential+    , MonadBase base+    )++instance MonadTrans (AWS c)+  where+    lift = AWST . lift . lift++instance MonadTransControl (AWS c)+  where+    newtype StT (AWS c) a = StAWS { unStAWS :: (a, c) }+    liftWith f = AWST . StateT $ \s -> ReaderT $ \r ->+        liftM (\x -> (x, s))+            (f $ \a -> liftM StAWS+                (R.runReaderT (S.runStateT (runAWST a) s) r))+    restoreT+        = AWST . StateT . const . ReaderT . const . liftM unStAWS++instance MonadBaseControl base m => MonadBaseControl base (AWS c m)+  where+    newtype StM (AWS c m) a+        = StMAWS { unStMAWS :: ComposeSt (AWS c) m a }+    liftBaseWith = defaultLiftBaseWith StMAWS+    restoreM = defaultRestoreM unStMAWS++runAWS :: MonadIO m+    => (HTTP.Manager -> c)+    -> Credential+    -> AWS c m a+    -> m a+runAWS ctx cred app = do+    mgr <- liftIO $ HTTP.newManager HTTP.def+    R.runReaderT+        (S.evalStateT (runAWST app) $ ctx mgr)+        cred

@@ -3,9 +3,9 @@  module AWS.EC2     ( -- * EC2 Environment-      module AWS.EC2.Class-    , EC2Endpoint(..)-    , setEndpoint+      EC2+    , runEC2+    , setRegion       -- * Instances     , module AWS.EC2.Instance       -- * Images@@ -30,9 +30,12 @@ import Data.Conduit import Control.Monad.Trans.Control (MonadBaseControl) import qualified Control.Monad.State as State+import Data.Text (Text) -import AWS.Types-import AWS.EC2.Class+import AWS.Util+import AWS.EC2.Internal+import AWS.EC2.Types+import qualified AWS.EC2.Util as Util  import AWS.EC2.Image import AWS.EC2.Region@@ -45,9 +48,17 @@ import AWS.EC2.KeyPair import AWS.EC2.SecurityGroup -setEndpoint+-- | set endpoint to EC2 context.+setRegion     :: (MonadResource m, MonadBaseControl IO m)-    => EC2Endpoint -> EC2 m ()-setEndpoint ep = do+    => Text -- ^ RegionName+    -> EC2 m ()+setRegion name = do+    region <- Util.head $ describeRegions [name] []     ctx <- State.get-    State.put ctx { endpoint = ep }+    maybe+        (fail "region not found")+        (\r -> State.put ctx { endpoint = f r })+        region+  where+    f = textToBS . regionEndpoint

@@ -17,8 +17,8 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Internal import AWS.EC2.Types-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser import AWS.Util

@@ -11,8 +11,8 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Internal import AWS.EC2.Types-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser 

@@ -1,93 +0,0 @@-{-# 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.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, liftIO)-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-    , 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)--instance Exception ResponseParserException--newtype EC2 m a = EC2T-    { 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--instance MonadTransControl EC2 where-    newtype StT EC2 a = StEC2 { unStEC2 :: (a, EC2Context) }-    liftWith f = EC2T . StateT $ \s -> ReaderT $ \r ->-        liftM (\x -> (x, s))-            (f $ \a -> liftM StEC2-                (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 :: 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

@@ -12,9 +12,9 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Params-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser import AWS.Util

@@ -30,9 +30,9 @@ import Data.Maybe (fromJust) import qualified Data.Map as Map +import AWS.EC2.Internal import AWS.EC2.Types import AWS.EC2.Params-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser import AWS.Util

@@ -0,0 +1,26 @@+module AWS.EC2.Internal+    ( AWSContext(..)+    , EC2+    , runEC2+      -- re-export+    , AWSException(..)+    ) where++import Control.Monad.IO.Class (MonadIO)+import qualified Network.HTTP.Conduit as HTTP+import Data.ByteString.Char8 ()++import AWS.Class+import AWS.Credential++initialEC2Context :: HTTP.Manager -> AWSContext+initialEC2Context mgr = AWSContext+    { manager = mgr+    , endpoint = "ec2.amazonaws.com"+    , lastRequestId = Nothing+    }++type EC2 m a = AWS AWSContext m a++runEC2 :: MonadIO m => Credential -> AWS AWSContext m a -> m a+runEC2 = runAWS initialEC2Context

@@ -14,8 +14,8 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Internal import AWS.EC2.Types-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser import AWS.Util

@@ -1,5 +1,5 @@ module AWS.EC2.Parser-    ( module AWS.EC2.Parser.Internal+    ( module AWS.Lib.Parser     , resourceTagSink     , productCodeSink     , stateReasonSink@@ -12,7 +12,7 @@ import Data.XML.Types (Event)  import AWS.EC2.Types-import AWS.EC2.Parser.Internal+import AWS.Lib.Parser import AWS.Util  resourceTagSink :: MonadThrow m

@@ -1,117 +0,0 @@-{-# 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-    }

@@ -1,49 +1,31 @@ {-# LANGUAGE FlexibleContexts, RankNTypes #-}-{-# LANGUAGE DeriveDataTypeable #-}  module AWS.EC2.Query     ( ec2Query     , ec2QuerySource     , ec2QuerySource'-    , ec2Request     , QueryParam(..)-    , EC2ClientException(..)+    , Filter     ) 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(..), Name(..))+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 (MonadIO, liftIO) import Control.Monad.Trans.Class (lift) 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-import AWS.Util+import AWS.EC2.Internal import AWS.EC2.Parser-import AWS.EC2.Class-import AWS.Credential+import AWS.Lib.Query  {- Debug import Debug.Trace@@ -51,147 +33,25 @@ 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]-    | 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+ec2Version :: ByteString+ec2Version = "2012-08-15"  sinkRequestId :: MonadThrow m     => GLSink Event m Text sinkRequestId = do     await -- EventBeginDocument     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+    getT "requestId" -sinkError :: MonadThrow m => GLSink Event m a-sinkError = do+sinkError :: MonadThrow m => Int -> GLSink Event m a+sinkError _ = do     await-    etag "Response" $ do-        (c,m) <- etag "Errors" $ etag "Error" $-            (,) <$> tagt "Code" <*> tagt "Message"-        r <- tagt "RequestID"+    element "Response" $ do+        (c,m) <- element "Errors" $ element "Error" $+            (,) <$> getT "Code" <*> getT "Message"+        r <- getT "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)-    => Credential-    -> EC2Context-    -> ByteString-    -> [QueryParam]-    -> m (ResumableSource m ByteString)-ec2Request cred ctx action params = do-    let mgr = manager ctx-    let ep = endpoint ctx-    time <- liftIO getCurrentTime-    let url = mkUrl ep cred time action params-    request <- liftIO $ HTTP.parseUrl (BSC.unpack url)-    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)     => ByteString@@ -222,7 +82,7 @@     cred <- Reader.ask     ctx <- State.get     (src1, rid) <- lift $ do-        response <- ec2Request cred ctx action params'+        response <- requestQuery cred ctx action params' ec2Version sinkError         (res, _) <- unwrapResumable response --        res $$ CB.sinkFile "debug.txt" >>= fail "debug"         res $= XmlP.parseBytes XmlP.def $$+ sinkRequestId

@@ -11,8 +11,8 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Internal import AWS.EC2.Types-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser 

@@ -20,8 +20,8 @@ import Control.Applicative import Data.Monoid +import AWS.EC2.Internal import AWS.EC2.Types-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser import AWS.Util

@@ -13,8 +13,8 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Internal import AWS.EC2.Types-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser import AWS.Util

@@ -12,8 +12,8 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Internal import AWS.EC2.Types-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser import AWS.Util

@@ -6,8 +6,6 @@  import AWS.Util -type Filter = (Text, [Text])- data Image = Image     { imageId :: Text     , imageLocation :: Text@@ -298,6 +296,7 @@     | Terminated     | Stopping     | Stopped+    | UnknownState Int   deriving (Show)  instanceStateCodes :: [(Int, InstanceState)]@@ -312,7 +311,7 @@  codeToState :: Int -> InstanceState codeToState code = case lookup code instanceStateCodes of-    Nothing -> error "invalid state code"+    Nothing -> UnknownState code     Just st -> st  data Placement = Placement

@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}++module AWS.EC2.Util+    ( asList+    , head+    , each+    ) where++import Data.Conduit+import qualified Data.Conduit.List as CL+import Control.Monad.Trans.Class (lift)+import Prelude hiding (head)++import AWS.EC2.Internal++asList+    :: Monad m+    => EC2 m (Source m a)+    -> EC2 m [a]+asList src = do+    s <- src+    lift $ s $$ CL.consume++head+    :: Monad m+    => EC2 m (Source m a)+    -> EC2 m (Maybe a)+head src = do+    s <- src+    lift $ s $$ CL.head++each+    :: Monad m+    => EC2 m (Source m a)+    -> (a -> m b)+    -> EC2 m ()+each src f = do+    s <- src+    (rsrc, _) <- lift $ s $$+ CL.take 0+    lift $ each' rsrc f++each'+    :: Monad m+    => ResumableSource m a+    -> (a -> m b)+    -> m ()+each' rsrc f = do+    (s', ma) <- rsrc $$++ CL.head+    case ma of+        Nothing -> return ()+        Just a  -> f a >> each' s' f

@@ -1,2 +0,0 @@-module AWS.EC2.Utils where-

@@ -14,8 +14,8 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative +import AWS.EC2.Internal import AWS.EC2.Types-import AWS.EC2.Class import AWS.EC2.Query import AWS.EC2.Parser import AWS.Util

@@ -0,0 +1,124 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+module AWS.Lib.Parser+    where++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++text :: MonadThrow m => GLSink Event m Text+text = XML.content++itemConduit :: MonadThrow m+    => Text+    -> GLSink Event m o+    -> GLConduit Event m o+itemConduit tag inner =+    maybe (()) id <$> elementM tag (listConduit "item" inner)++listConduit :: MonadThrow m+    => Text+    -> GLSink Event m o+    -> GLConduit Event m o+listConduit name p =+    awaitWhile isTag >>= maybe (return ()) (\e -> do+        leftover e+        if isBeginTagName name e+            then do+                element name $ p >>= yield+                listConduit name p+            else return ()+        )++listConsumer :: MonadThrow m+    => Text+    -> GLSink Event m o+    -> GLSink Event m [o]+listConsumer name p = listConduit name p >+> CL.consume++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++sinkDropWhile :: Monad m => (i -> Bool) -> GLSink i m ()+sinkDropWhile f = await >>= maybe (return ()) g+  where+      g i | f i       = sinkDropWhile f+              | otherwise = leftover i >> return ()++isBeginTagName :: Text -> Event -> Bool+isBeginTagName name (EventBeginElement n _)+    | nameLocalName n == 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 = tagContent 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 = tagContentM 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 = do+    sinkDropWhile $ not . isTag+    XML.tagPredicate g (return ()) $ const inner+  where+    g n = (nameLocalName n == name)++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++tagContentM :: MonadThrow m+    => Text+    -> GLSink Event m (Maybe Text)+tagContentM name = elementM name text++tagContent :: MonadThrow m+    => Text+    -> GLSink Event m Text+tagContent name =+    XML.force ("parse error:" ++ T.unpack name) $ tagContentM name

@@ -0,0 +1,165 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}++module AWS.Lib.Query+    ( requestQuery+    , QueryParam(..)+    , Filter+    ) 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 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 (MonadIO, liftIO)+import Control.Exception.Lifted as E+import Data.Text (Text)++import AWS.Class+import AWS.Util+import AWS.EC2.Parser ()+import AWS.Credential++{- Debug+import Debug.Trace+import qualified Data.Conduit.Binary as CB+import System.IO (stdout)+--}++type Filter = (Text, [Text])++data QueryParam+    = ArrayParams Text [Text]+    | FilterParams [Filter]+    | ValueParam Text Text+    | StructArrayParams Text [[(Text, Text)]]+  deriving (Show)++queryHeader+    :: ByteString+    -> UTCTime+    -> Credential+    -> ByteString+    -> [(ByteString, ByteString)]+queryHeader action time cred ver =+    [ ("Action", action)+    , ("Version", ver)+    , ("SignatureVersion", "2")+    , ("SignatureMethod", "HmacSHA256")+    , ("Timestamp", H.urlEncode True $ awsTimeFormat time)+    , ("AWSAccessKeyId", accessKey cred)+    ]++mkUrl :: ByteString+      -> Credential+      -> UTCTime+      -> ByteString+      -> [QueryParam]+      -> ByteString+      -> ByteString+mkUrl ep cred time action params ver = mconcat+    [ "https://"+    , ep+    , "/?"+    , qparam+    , "&Signature="+    , signature ep (secretAccessKey cred) qparam+    ]+  where+    qheader = Map.fromList $ queryHeader action time cred ver+    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+    :: ByteString -> SecretAccessKey -> ByteString -> ByteString+signature ep secret query = urlstr+  where+    stringToSign = "GET\n" <> ep <> "\n/\n" <> query+    signedStr = toS . SHA.bytestringDigest $ SHA.hmacSha256 (toL secret) (toL stringToSign)+    urlstr = H.urlEncode True . BASE.encode $ signedStr++checkStatus' ::+    H.Status -> H.ResponseHeaders -> Maybe SomeException+checkStatus' = \s@(H.Status sci _) hs ->+    if 200 <= sci && sci < 300 || 400 <= sci+        then Nothing+        else Just $ toException $ HTTP.StatusCodeException s hs++clientError+    :: (MonadResource m, MonadBaseControl IO m)+    => Int+    -> ResumableSource m ByteString+    -> (Int -> GLSink Event m a)+    -> m a+clientError status rsrc errSink =+    rsrc $$+- XmlP.parseBytes XmlP.def =$ errSink status++requestQuery+    :: (MonadResource m, MonadBaseControl IO m)+    => Credential+    -> AWSContext+    -> ByteString+    -> [QueryParam]+    -> ByteString+    -> (Int -> GLSink Event m a)+    -> m (ResumableSource m ByteString)+requestQuery cred ctx action params ver errSink = do+    let mgr = manager ctx+    let ep = endpoint ctx+    time <- liftIO getCurrentTime+    let url = mkUrl ep cred time action params ver+    request <- liftIO $ HTTP.parseUrl (BSC.unpack url)+    let req = request { HTTP.checkStatus = checkStatus' }+    response <- HTTP.http req mgr+    let body = HTTP.responseBody response+    let st = H.statusCode $ HTTP.responseStatus response+    if st < 400+        then return body+        else do+            clientError st body errSink+            fail "not reached"

@@ -0,0 +1,202 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}++module AWS.RDS+    ( -- * RDS Environment+      RDS+    , runRDS+    , setRegion+      -- * DBInstance+    , describeDBInstances+    ) where++import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Conduit+import Control.Applicative+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class (MonadIO)+import qualified Control.Monad.State as State+import qualified Control.Monad.Reader as Reader+import qualified Network.HTTP.Conduit as HTTP+import Data.Monoid ((<>))+import qualified Text.XML.Stream.Parse as XML+import Data.XML.Types (Event(..))+import Data.Maybe (catMaybes)++import AWS.Class+import AWS.Util+import AWS.Lib.Query+import AWS.Lib.Parser++import AWS+import AWS.RDS.Types++--import qualified Data.Conduit.Binary as CB++apiVersion :: ByteString+apiVersion = "2012-09-17"++type RequestId = Text++type RDS m a = AWS AWSContext m a++initialRDSContext :: HTTP.Manager -> AWSContext+initialRDSContext mgr = AWSContext+    { manager = mgr+    , endpoint = "rds.amazonaws.com"+    , lastRequestId = Nothing+    }++runRDS :: MonadIO m => Credential -> RDS m a -> m a+runRDS = runAWS initialRDSContext++describeDBInstances+    :: (MonadBaseControl IO m, MonadResource m)+    => Maybe Text -- ^ DBInstanceIdentifier+    -> Maybe Int -- ^ MaxRecords+    -> Maybe Text -- ^ Marker+    -> RDS m [DBInstance]+describeDBInstances dbid maxRecords marker = do+    ctx <- State.get+    cred <- Reader.ask+    rs <- lift $ requestQuery cred ctx (textToBS action) params apiVersion undefined+--    lift $ rs $$+- CB.sinkFile "debug.txt" >> fail "debug"+    (res, rid) <- lift $ rs $$+- XML.parseBytes XML.def =$ do+        sinkResponse action $ sinkDBInstances+    State.put ctx { lastRequestId = Just rid }+    return res+  where+    action = "DescribeDBInstances"+    mk name = maybe [] (\a -> [ValueParam name a])+    params = uncurry mk =<<+        [ ("DBInstanceIdentifier", dbid)+        , ("MaxRecords", toText <$> maxRecords)+        , ("Marker", marker)+        ]++elements :: MonadThrow m+    => Text+    -> GLSink Event m a+    -> GLSink Event m [a]+elements name f = element (name <> "s") $ listConsumer name f++sinkDBInstances+    :: MonadThrow m+    => GLSink Event m [DBInstance]+sinkDBInstances = elements "DBInstance" $+    DBInstance+    <$> getM "Iops" (textToInt <$>)+    <*> getF "BackupRetentionPeriod" textToInt+    <*> getF "MultiAZ" textToBool+    <*> getT "DBInstanceStatus"+    <*> getT "DBInstanceIdentifier"+    <*> getT "PreferredBackupWindow"+    <*> getT "PreferredMaintenanceWindow"+    <*> elementM "OptionGroupMembership"+        (OptionGroupMembership+        <$> getT "OptionGroupName"+        <*> getT "Status"+        )+    <*> getT "AvailabilityZone"+    <*> getM "LatestRestorableTime" (textToTime <$>)+    <*> elements "ReadReplicaDBInstanceIdentifier" text+    <*> getT "Engine"+    <*> sinkPendingModifiedValues+    <*> getMT "CharacterSetName"+    <*> getT "LicenseModel"+    <*> elementM "DBSubnetGroup"+        (DBSubnetGroup+        <$> getT "VpcId"+        <*> getT "SubnetGroupStatus"+        <*> getT "DBSubnetGroupDescription"+        <*> getT "DBSubnetGroupName"+        <*> elements "Subnet"+            (Subnet+            <$> getT "SubnetStatus"+            <*> getT "SubnetIdentifier"+            <*> element "SubnetAvailabilityZone"+                (AvailabilityZone+                <$> getT "Name"+                <*> getF "ProvisionedIopsCapable" textToBool+                )+            )+        )+    <*> elements "DBParameterGroup"+        (DBParameterGroupStatus+        <$> getT "ParameterApplyStatus"+        <*> getT "DBParameterGroupName"+        )+    <*> elementM "Endpoint"+        (Endpoint+        <$> getF "Port" textToInt+        <*> getT "Address"+        )+    <*> getT "EngineVersion"+    <*> getMT "ReadReplicaSourceDBInstanceIdentifier"+    <*> elements "DBSecurityGroup"+        (DBSecurityGroupMembership+        <$> getT "Status"+        <*> getT "DBSecurityGroupName"+        )+    <*> getMT "DBName"+    <*> getF "AutoMinorVersionUpgrade" textToBool+    <*> getM "InstanceCreateTime" (textToTime <$>)+    <*> getF "AllocatedStorage" textToInt+    <*> getT "DBInstanceClass"+    <*> getT "MasterUsername" ++sinkPendingModifiedValues+    :: MonadThrow m+    => GLSink Event m [PendingModifiedValue]+sinkPendingModifiedValues = element "PendingModifiedValues" $+    catMaybes <$> sequence [ m "MasterUserPassword" PMVMasterUserPassword+        , m "Iops" (PMVIops . textToInt)+        , m "MultiAZ" (PMVMultiAZ . textToBool)+        , m "AllocatedStorage" (PMVAllocatedStorage . textToInt)+        , m "EngineVersion" PMVEngineVersion+        , m "DBInstanceClass" PMVDBInstanceClass+        , m "BackupRetentionPeriod"+            (PMVBackupRetentionPeriod . textToInt)+        , m "Port" (PMVPort . textToInt)+        ]+  where+    m t f = getM t (f <$>)++sinkResponse+    :: MonadThrow m+    => Text -- ^ Action+    -> GLSink Event m a+    -> GLSink Event m (a, RequestId)+sinkResponse action sink = do+    sinkEventBeginDocument+    element (action <> "Response") $ (,)+        <$> element (action <> "Result") sink -- XXX: parse Marker+        <*> sinkResponseMetadata++sinkResponseMetadata+    :: MonadThrow m+    => GLSink Event m Text+sinkResponseMetadata =+    element "ResponseMetadata" $+        getT "RequestId"++sinkEventBeginDocument+    :: MonadThrow m+    => GLSink Event m ()+sinkEventBeginDocument = do+    me <- await+    case me of+        Nothing -> return ()+        Just EventBeginDocument -> return ()+        Just _ -> fail $ "unexpected: " <> show me++setRegion+    :: (MonadBaseControl IO m, MonadResource m)+    => Text -> RDS m ()+setRegion region = do+    ctx <- State.get+    State.put+        ctx { endpoint =+            "rds." <> textToBS region <> ".amazonaws.com"+            }

@@ -0,0 +1,93 @@+module AWS.RDS.Types+    where++import Data.Text (Text)+import Data.Time (UTCTime)++data DBInstance = DBInstance+    { dbiIops :: Maybe Int+    , dbiBackupRetentionPeriod :: Int+    , dbiMultiAZ :: Bool+    , dbiDBInstanceStatus :: Text+    , dbiDBInstanceIdentifier :: Text+    , dbiPreferredBackupWindow :: Text+    , dbiPreferredMaintenanceWindow :: Text+    , dbiOptionGroupMembership :: Maybe OptionGroupMembership+    , dbiAvailabilityZone :: Text+    , dbiLatestRestorableTime :: Maybe UTCTime+    , dbiReadReplicaDBInstanceIdentifiers :: [Text]+    , dbiEngine :: Text+    , dbiPendingModifiedValues :: [PendingModifiedValue]+    , dbiCharacterSetName :: Maybe Text+    , dbiLicenseModel :: Text+    , dbiSubnetGroup :: Maybe DBSubnetGroup+    , dbiDBParameterGroups :: [DBParameterGroupStatus]+    , dbiEndpoint :: Maybe Endpoint+    , dbiEngineVersion :: Text+    , dbiReadReplicaSourceDBInstanceIdentifier :: Maybe Text+    , dbiSecurityGroups :: [DBSecurityGroupMembership]+    , dbiDBName :: Maybe Text+    , dbiAutoMinorVersionUpgrade :: Bool+    , dbiInstanceCreateTime :: Maybe UTCTime+    , dbiAllocatedStorage :: Int -- ^ storage size in gigabytes+    , dbiDBInstanceClass :: Text+    , dbiMasterUsername :: Text+    }+  deriving (Show)++data DBParameterGroupStatus = DBParameterGroupStatus+    { dbpgsParameterApplyStatus :: Text+    , dbpgsDBParameterGroupName :: Text+    }+  deriving (Show)++data DBSecurityGroupMembership = DBSecurityGroupMembership+    { dbsgmStatus :: Text+    , dbsgmDBSecurityGroupName :: Text+    }+  deriving (Show)++data DBSubnetGroup = DBSubnetGroup+    { dbsngVpcId :: Text+    , dbsngSubnetGroupStatus :: Text+    , dbsngDBSubnetGroupDescription :: Text+    , dbsngDBSubnetGroupName :: Text+    , dbsngSubnets :: [Subnet]+    }+  deriving (Show)++data Subnet = Subnet+    { subnetStatus :: Text+    , subnetIdentifier :: Text+    , subnetAvailabilityZone :: AvailabilityZone+    }+  deriving (Show)++data AvailabilityZone = AvailabilityZone+    { azName :: Text+    , azProvisionedIopsCapable :: Bool+    }+  deriving (Show)++data Endpoint = Endpoint+    { epPort :: Int+    , epAddress :: Text+    }+  deriving (Show)++data OptionGroupMembership = OptionGroupMembership+    { ogmOptionGroupName :: Text+    , ogmStatus :: Text+    }+  deriving (Show)++data PendingModifiedValue+    = PMVAllocatedStorage Int+    | PMVBackupRetentionPeriod Int+    | PMVDBInstanceClass Text+    | PMVEngineVersion Text+    | PMVIops Int+    | PMVMasterUserPassword Text+    | PMVMultiAZ Bool+    | PMVPort Int+  deriving (Show)

@@ -1,18 +1,3 @@ {-# 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+module AWS.Types where -instance Endpoint EC2Endpoint where-    endpointStr UsEast1      = "ec2.us-east-1.amazonaws.com"-    endpointStr ApNortheast1 = "ec2.ap-northeast-1.amazonaws.com"

@@ -1,5 +1,5 @@ name:                aws-sdk-version:             0.2.0.0+version:             0.3.0.0 synopsis:            AWS SDK for Haskell description:         An AWS(Amazon Web Services) liblary for Haskell. license:             BSD3@@ -17,9 +17,13 @@                    , AWS.Types                    , AWS.EC2                    , AWS.EC2.Types-                   , AWS.EC2.Utils+                   , AWS.EC2.Util+                   , AWS.RDS+                   , AWS.RDS.Types   other-modules:     AWS.Util                    , AWS.Credential+                   , AWS.Class+                   , AWS.EC2.Internal                    , AWS.EC2.Address                    , AWS.EC2.AvailabilityZone                    , AWS.EC2.Image@@ -32,10 +36,10 @@                    , AWS.EC2.Query                    , AWS.EC2.Region                    , AWS.EC2.Tag-                   , AWS.EC2.Class                    , AWS.EC2.Parser-                   , AWS.EC2.Parser.Internal                    , AWS.EC2.Params+                   , AWS.Lib.Parser+                   , AWS.Lib.Query   ghc-options:       -Wall                      -fno-warn-unused-do-bind   extensions: OverloadedStrings