aws (empty) → 0.0.1
raw patch · 43 files changed
+1842/−0 lines, 43 filesdep +asciidep +basedep +base64-bytestringsetup-changed
Dependencies added: ascii, base, base64-bytestring, blaze-builder, bytestring, cereal, containers, crypto-api, cryptohash, directory, enumerator, filepath, http-enumerator, http-types, mtl, old-locale, shortcircuit, time, transformers, transformers-compose, utf8-string, wai, xml, xml-monad
Files
- Aws.hs +25/−0
- Aws/Aws.hs +123/−0
- Aws/Credentials.hs +52/−0
- Aws/Debug.hs +7/−0
- Aws/Http.hs +24/−0
- Aws/Metadata.hs +7/−0
- Aws/Query.hs +68/−0
- Aws/Response.hs +32/−0
- Aws/S3.hs +19/−0
- Aws/S3/Commands.hs +9/−0
- Aws/S3/Commands/GetBucket.hs +60/−0
- Aws/S3/Commands/GetService.hs +49/−0
- Aws/S3/Error.hs +30/−0
- Aws/S3/Info.hs +85/−0
- Aws/S3/Metadata.hs +9/−0
- Aws/S3/Model.hs +56/−0
- Aws/S3/Query.hs +79/−0
- Aws/S3/Response.hs +48/−0
- Aws/Signature.hs +68/−0
- Aws/SimpleDb.hs +19/−0
- Aws/SimpleDb/Commands.hs +25/−0
- Aws/SimpleDb/Commands/BatchDeleteAttributes.hs +41/−0
- Aws/SimpleDb/Commands/BatchPutAttributes.hs +41/−0
- Aws/SimpleDb/Commands/CreateDomain.hs +34/−0
- Aws/SimpleDb/Commands/DeleteAttributes.hs +48/−0
- Aws/SimpleDb/Commands/DeleteDomain.hs +34/−0
- Aws/SimpleDb/Commands/DomainMetadata.hs +54/−0
- Aws/SimpleDb/Commands/GetAttributes.hs +51/−0
- Aws/SimpleDb/Commands/ListDomains.hs +48/−0
- Aws/SimpleDb/Commands/PutAttributes.hs +48/−0
- Aws/SimpleDb/Commands/Select.hs +50/−0
- Aws/SimpleDb/Error.hs +41/−0
- Aws/SimpleDb/Info.hs +42/−0
- Aws/SimpleDb/Metadata.hs +9/−0
- Aws/SimpleDb/Model.hs +76/−0
- Aws/SimpleDb/Query.hs +51/−0
- Aws/SimpleDb/Response.hs +66/−0
- Aws/Transaction.hs +9/−0
- Aws/Util.hs +47/−0
- LICENSE +30/−0
- README +1/−0
- Setup.hs +2/−0
- aws.cabal +125/−0
+ Aws.hs view
@@ -0,0 +1,25 @@+module Aws+(+ module Aws.Aws+, module Aws.Credentials+, module Aws.Debug+, module Aws.Http+, module Aws.Metadata+, module Aws.Query+, module Aws.Response+, module Aws.Signature+, module Aws.Transaction+, module Aws.Util+)+where++import Aws.Aws+import Aws.Credentials+import Aws.Debug+import Aws.Http+import Aws.Metadata+import Aws.Query+import Aws.Response+import Aws.Signature+import Aws.Transaction+import Aws.Util
+ Aws/Aws.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FlexibleContexts #-}+module Aws.Aws+where++import Aws.Credentials+import Aws.Debug+import Aws.Http+import Aws.Query+import Aws.Response+import Aws.S3.Info+import Aws.Signature+import Aws.SimpleDb.Info+import Aws.Transaction+import Control.Applicative+import Control.Monad.Reader+import qualified Data.ByteString as B+import qualified Data.Enumerator as En+import qualified Network.HTTP.Enumerator as HTTP++data Configuration+ = Configuration {+ timeInfo :: TimeInfo+ , credentials :: Credentials+ , sdbInfo :: SdbInfo+ , sdbInfoUri :: SdbInfo+ , s3Info :: S3Info+ , s3InfoUri :: S3Info+ }++class ConfigurationFetch a where+ configurationFetch :: Configuration -> a+ configurationFetchUri :: Configuration -> a+ configurationFetchUri = configurationFetch++instance ConfigurationFetch () where+ configurationFetch _ = ()++instance ConfigurationFetch SdbInfo where+ configurationFetch = sdbInfo+ configurationFetchUri = sdbInfoUri++instance ConfigurationFetch S3Info where+ configurationFetch = s3Info+ configurationFetchUri = s3InfoUri++baseConfiguration :: MonadIO io => io Configuration+baseConfiguration = do+ Just cr <- loadCredentialsDefault+ return Configuration {+ timeInfo = Timestamp+ , credentials = cr+ , sdbInfo = sdbHttpsPost sdbUsEast+ , sdbInfoUri = sdbHttpsGet sdbUsEast+ , s3Info = s3 HTTP s3EndpointUsClassic False+ , s3InfoUri = s3 HTTP s3EndpointUsClassic True+ }+-- TODO: better error handling when credentials cannot be loaded++debugConfiguration :: MonadIO io => io Configuration+debugConfiguration = do + c <- baseConfiguration+ return c { sdbInfo = sdbHttpPost sdbUsEast, sdbInfoUri = sdbHttpGet sdbUsEast }++newtype AwsT m a = AwsT { fromAwsT :: ReaderT Configuration m a }++type Aws = AwsT IO++runAws :: AwsT m a -> Configuration -> m a+runAws = runReaderT . fromAwsT++runAws' :: MonadIO io => AwsT io a -> io a+runAws' a = baseConfiguration >>= runAws a++runAwsDebug :: MonadIO io => AwsT io a -> io a+runAwsDebug a = debugConfiguration >>= runAws a++instance Monad m => Monad (AwsT m) where+ return = AwsT . return+ m >>= k = AwsT $ fromAwsT m >>= fromAwsT . k++instance MonadIO m => MonadIO (AwsT m) where+ liftIO = AwsT . liftIO++class MonadIO aws => MonadAws aws where+ configuration :: MonadAws aws => aws Configuration++instance MonadIO m => MonadAws (AwsT m) where+ configuration = AwsT ask++aws :: (Transaction request response+ , ConfigurationFetch (Info request)+ , MonadAws aws) + => request -> aws response+aws = unsafeAws++unsafeAws+ :: (MonadAws m,+ ResponseIteratee response,+ SignQuery request,+ ConfigurationFetch (Info request)) =>+ request -> m response+unsafeAws request = do+ cfg <- configuration+ sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg+ let info = configurationFetch cfg+ let q = signQuery request info sd+ debugPrint "String to sign" $ sqStringToSign q+ let httpRequest = queryToHttpRequest q+ liftIO $ HTTP.withManager $ En.run_ . HTTP.httpRedirect httpRequest responseIteratee++awsUri :: (SignQuery request+ , ConfigurationFetch (Info request)+ , MonadAws aws)+ => request -> aws B.ByteString+awsUri request = do+ cfg <- configuration+ let ti = timeInfo cfg+ cr = credentials cfg+ info = configurationFetchUri cfg+ sd <- liftIO $ signatureData ti cr+ let q = signQuery request info sd+ debugPrint "String to sign" $ sqStringToSign q+ return $ queryToUri q
+ Aws/Credentials.hs view
@@ -0,0 +1,52 @@+module Aws.Credentials+where+ +import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.Shortcircuit (orM)+import Data.List+import System.Directory+import System.Environment+import System.FilePath+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as BU++data Credentials+ = Credentials {+ accessKeyID :: B.ByteString+ , secretAccessKey :: B.ByteString+ }+ deriving (Show)+ +credentialsDefaultFile :: MonadIO io => io FilePath+credentialsDefaultFile = liftIO $ (</> ".aws-keys") <$> getHomeDirectory++credentialsDefaultKey :: String+credentialsDefaultKey = "default"++loadCredentialsFromFile :: MonadIO io => FilePath -> String -> io (Maybe Credentials)+loadCredentialsFromFile file key = liftIO $ do+ contents <- map words . lines <$> readFile file+ return $ do + [_key, keyID, secret] <- find (hasKey key) contents+ return Credentials { accessKeyID = BU.fromString keyID, secretAccessKey = BU.fromString secret }+ where+ hasKey _ [] = False+ hasKey k (k2 : _) = k == k2++loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials)+loadCredentialsFromEnv = liftIO $ do+ env <- getEnvironment+ let lk = flip lookup env+ keyID = lk "AWS_ACCESS_KEY_ID"+ secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY"+ return (Credentials <$> (BU.fromString <$> keyID) <*> (BU.fromString <$> secret))+ +loadCredentialsFromEnvOrFile :: MonadIO io => FilePath -> String -> io (Maybe Credentials)+loadCredentialsFromEnvOrFile file key = loadCredentialsFromEnv `orM` loadCredentialsFromFile file key++loadCredentialsDefault :: MonadIO io => io (Maybe Credentials)+loadCredentialsDefault = do+ file <- credentialsDefaultFile+ loadCredentialsFromEnvOrFile file credentialsDefaultKey
+ Aws/Debug.hs view
@@ -0,0 +1,7 @@+module Aws.Debug+where+ +import Control.Monad.IO.Class++debugPrint :: (MonadIO io, Show a) => String -> a -> io ()+debugPrint p v = liftIO . putStrLn $ "AWS Debug: " ++ p ++ " - " ++ show v
+ Aws/Http.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++module Aws.Http+where+ +import qualified Network.HTTP.Types as HTTP++data Protocol+ = HTTP+ | HTTPS+ deriving (Show)++defaultPort :: Protocol -> Int+defaultPort HTTP = 80+defaultPort HTTPS = 443++data Method+ = Get+ | PostQuery+ deriving (Show, Eq)++httpMethod :: Method -> HTTP.Method+httpMethod Get = "GET"+httpMethod PostQuery = "POST"
+ Aws/Metadata.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+module Aws.Metadata+where+ +class WithMetadata a m | a -> m where+ getMetadata :: a -> Maybe m+ setMetadata :: m -> a -> a
+ Aws/Query.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+module Aws.Query+where++import Aws.Http+import Aws.Util+import Data.Maybe+import Data.Time+import qualified Blaze.ByteString.Builder as Blaze+import qualified Data.Ascii as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.UTF8 as BU+import qualified Network.HTTP.Enumerator as HTTP+import qualified Network.HTTP.Types as HTTP++data SignedQuery + = SignedQuery {+ sqMethod :: Method+ , sqProtocol :: Protocol+ , sqHost :: A.Ascii+ , sqPort :: Int+ , sqPath :: A.Ascii+ , sqQuery :: HTTP.Query+ , sqDate :: Maybe UTCTime+ , sqAuthorization :: Maybe A.Ascii+ , sqContentType :: Maybe A.Ascii+ , sqContentMd5 :: Maybe A.Ascii+ , sqBody :: L.ByteString+ , sqStringToSign :: B.ByteString+ }+ deriving (Show)++queryToHttpRequest :: SignedQuery -> HTTP.Request m+queryToHttpRequest SignedQuery{..}+ = HTTP.Request {+ HTTP.method = httpMethod sqMethod+ , HTTP.secure = case sqProtocol of+ HTTP -> False+ HTTPS -> True+ , HTTP.checkCerts = const (return True) -- FIXME: actually check certificates+ , HTTP.host = sqHost+ , HTTP.port = sqPort+ , HTTP.path = sqPath+ , HTTP.queryString = sqQuery+ , HTTP.requestHeaders = catMaybes [fmap (\d -> ("Date", fmtRfc822Time d)) sqDate+ , fmap (\c -> ("Content-Type", c)) contentType+ , fmap (\md5 -> ("Content-MD5", md5)) sqContentMd5+ , fmap (\auth -> ("Authorization", auth)) sqAuthorization]+ , HTTP.requestBody = HTTP.RequestBodyLBS $ case sqMethod of+ Get -> L.empty+ PostQuery -> Blaze.toLazyByteString . A.toBuilder $ HTTP.renderQueryBuilder False sqQuery+ }+ where contentType = case sqMethod of+ PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8"+ _ -> sqContentType++queryToUri :: SignedQuery -> B.ByteString+queryToUri SignedQuery{..} + = B.concat [+ case sqProtocol of+ HTTP -> "http://"+ HTTPS -> "https://"+ , A.toByteString sqHost+ , if sqPort == defaultPort sqProtocol then "" else BU.fromString $ ':' : show sqPort+ , A.toByteString sqPath+ , A.toByteString $ HTTP.renderQuery True sqQuery+ ]
+ Aws/Response.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-}++module Aws.Response+where+ +import Control.Monad.Compose.Class+import Control.Monad.Error.Class+import Control.Monad.Reader.Class+import Text.XML.Monad+import qualified Control.Exception as C+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.UTF8 as BLU+import qualified Data.Enumerator as En+import qualified Network.HTTP.Enumerator as HTTP+import qualified Network.HTTP.Types as HTTP+import qualified Text.XML.Light as XL++class ResponseIteratee a where+ responseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a+ +instance ResponseIteratee HTTP.Response where+ responseIteratee = HTTP.lbsIter++xmlResponseIteratee :: C.Exception e => Xml e HTTP.Response a -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a+xmlResponseIteratee xml status headers = do+ body <- HTTP.lbsIter status headers+ case runXml xml body of+ Left e -> En.throwError e+ Right a -> return a++parseXmlResponse :: (FromXmlError e, Error e) => Xml e HTTP.Response XL.Element+parseXmlResponse = parseXMLDoc <<< asks (BLU.toString . HTTP.responseBody)
+ Aws/S3.hs view
@@ -0,0 +1,19 @@+module Aws.S3+(+ module Aws.S3.Commands+, module Aws.S3.Error+, module Aws.S3.Info+, module Aws.S3.Metadata+, module Aws.S3.Model+, module Aws.S3.Query+, module Aws.S3.Response+)+where++import Aws.S3.Commands+import Aws.S3.Error+import Aws.S3.Info+import Aws.S3.Metadata+import Aws.S3.Model+import Aws.S3.Query+import Aws.S3.Response
+ Aws/S3/Commands.hs view
@@ -0,0 +1,9 @@+module Aws.S3.Commands+(+ module Aws.S3.Commands.GetBucket+, module Aws.S3.Commands.GetService+)+where++import Aws.S3.Commands.GetBucket+import Aws.S3.Commands.GetService
+ Aws/S3/Commands/GetBucket.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TypeFamilies, RecordWildCards, TupleSections, OverloadedStrings #-}+module Aws.S3.Commands.GetBucket+where++import Aws.S3.Info+import Aws.S3.Model+import Aws.S3.Query+import Aws.Signature+import Control.Applicative+import Control.Arrow (second)+import Data.ByteString.Char8 ({- IsString -})+import Data.Maybe+import qualified Data.Ascii as A+import qualified Data.ByteString.UTF8 as BU+import qualified Network.HTTP.Types as HTTP++data GetBucket+ = GetBucket {+ gbBucket :: Bucket+ , gbDelimiter :: Maybe String+ , gbMarker :: Maybe String+ , gbMaxKeys :: Maybe Int+ , gbPrefix :: Maybe String+ }+ deriving (Show)++getBucket :: Bucket -> GetBucket+getBucket bucket + = GetBucket { + gbBucket = bucket+ , gbDelimiter = Nothing+ , gbMarker = Nothing+ , gbMaxKeys = Nothing+ , gbPrefix = Nothing+ }++data GetBucketResult+ = GetBucketResult {+ gbrName :: Bucket+ , gbrDelimiter :: Maybe String+ , gbrMarker :: Maybe String+ , gbrMaxKeys :: Maybe Int+ , gbrPrefix :: Maybe String+ , gbrContents :: [ObjectInfo]+ , gbrCommonPrefixes :: [String]+ }+ deriving (Show)++instance SignQuery GetBucket where+ type Info GetBucket = S3Info+ signQuery GetBucket {..} = s3SignQuery S3Query { + s3QBucket = Just $ A.unsafeFromString gbBucket+ , s3QSubresources = []+ , s3QQuery = HTTP.simpleQueryToQuery $ map (second BU.fromString) $ catMaybes [+ ("delimiter",) <$> gbDelimiter+ , ("marker",) <$> gbMarker+ , ("max-keys",) <$> show <$> gbMaxKeys+ , ("prefix",) <$> gbPrefix+ ]+ }
+ Aws/S3/Commands/GetService.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}+module Aws.S3.Commands.GetService+where+ +import Aws.Response+import Aws.S3.Error+import Aws.S3.Info+import Aws.S3.Model+import Aws.S3.Query+import Aws.S3.Response+import Aws.Signature+import Aws.Transaction+import Control.Monad.Compose.Class+import Data.Time.Format+import System.Locale+import Text.XML.Monad+import qualified Text.XML.Light as XL++data GetService = GetService++data GetServiceResponse + = GetServiceResponse {+ gsrOwner :: UserInfo+ , gsrBuckets :: [BucketInfo]+ }+ deriving (Show)++instance S3ResponseIteratee GetServiceResponse where+ s3ResponseIteratee = xmlResponseIteratee $ parse <<< parseXmlResponse+ where+ parse :: Xml S3Error XL.Element GetServiceResponse+ parse = do+ owner <- parseUserInfo <<< findElementNameUI "Owner"+ buckets <- inList parseBucket <<< findElementsNameUI "Bucket"+ + return GetServiceResponse { gsrOwner = owner, gsrBuckets = buckets }+ + parseBucket = do+ name <- strContent <<< findElementNameUI "Name"+ creationDateString <- strContent <<< findElementNameUI "CreationDate"+ creationDate <- maybeRaiseXml (EncodingError "Invalid date encoding") $+ parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" creationDateString+ return BucketInfo { bucketName = name, bucketCreationDate = creationDate }++instance SignQuery GetService where+ type Info GetService = S3Info+ signQuery GetService = s3SignQuery S3Query { s3QBucket = Nothing, s3QSubresources = [], s3QQuery = [] }++instance Transaction GetService (S3Response GetServiceResponse)
+ Aws/S3/Error.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses #-}+module Aws.S3.Error+where++import Aws.Metadata+import Aws.S3.Metadata+import Control.Monad.Error.Class+import Data.Typeable+import Text.XML.Monad+import qualified Control.Exception as C++data S3Error+ = S3XmlError { + fromS3XmlError :: XmlError+ , s3XmlErrorMetadata :: Maybe S3Metadata+ }+ deriving (Show, Typeable)++instance C.Exception S3Error++instance FromXmlError S3Error where+ fromXmlError = flip S3XmlError Nothing++instance Error S3Error where+ noMsg = fromXmlError noMsg+ strMsg = fromXmlError . strMsg++instance WithMetadata S3Error S3Metadata where+ getMetadata = s3XmlErrorMetadata+ setMetadata m a = a { s3XmlErrorMetadata = Just m }
+ Aws/S3/Info.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+module Aws.S3.Info+where++import Aws.Http+import Aws.S3.Model+import Data.Time+import qualified Data.Ascii as A++data S3Authorization + = S3AuthorizationHeader + | S3AuthorizationQuery+ deriving (Show)++data Endpoint+ = Endpoint {+ endpointHost :: A.Ascii+ , endpointDefaultLocationConstraint :: LocationConstraint+ , endpointAllowedLocationConstraints :: [LocationConstraint]+ }+ deriving (Show)++data S3Info+ = S3Info {+ s3Protocol :: Protocol+ , s3Endpoint :: Endpoint+ , s3Port :: Int+ , s3UseUri :: Bool+ , s3DefaultExpiry :: NominalDiffTime+ }+ deriving (Show)++s3EndpointUsClassic :: Endpoint+s3EndpointUsClassic + = Endpoint { + endpointHost = "s3.amazonaws.com"+ , endpointDefaultLocationConstraint = locationUsClassic+ , endpointAllowedLocationConstraints = [locationUsClassic+ , locationUsWest+ , locationEu+ , locationApSouthEast+ , locationApNorthEast]+ }++s3EndpointUsWest :: Endpoint+s3EndpointUsWest+ = Endpoint {+ endpointHost = "s3-us-west-1.amazonaws.com"+ , endpointDefaultLocationConstraint = locationUsWest+ , endpointAllowedLocationConstraints = [locationUsWest]+ }++s3EndpointEu :: Endpoint+s3EndpointEu+ = Endpoint {+ endpointHost = "s3-eu-west-1.amazonaws.com"+ , endpointDefaultLocationConstraint = locationEu+ , endpointAllowedLocationConstraints = [locationEu]+ }++s3EndpointApSouthEast :: Endpoint+s3EndpointApSouthEast+ = Endpoint {+ endpointHost = "s3-ap-southeast-1.amazonaws.com"+ , endpointDefaultLocationConstraint = locationApSouthEast+ , endpointAllowedLocationConstraints = [locationApSouthEast]+ }++s3EndpointApNorthEast :: Endpoint+s3EndpointApNorthEast+ = Endpoint {+ endpointHost = "s3-ap-northeast-1.amazonaws.com"+ , endpointDefaultLocationConstraint = locationApNorthEast+ , endpointAllowedLocationConstraints = [locationApNorthEast]+ }++s3 :: Protocol -> Endpoint -> Bool -> S3Info+s3 protocol endpoint uri + = S3Info { + s3Protocol = protocol+ , s3Endpoint = endpoint+ , s3Port = defaultPort protocol+ , s3UseUri = uri+ , s3DefaultExpiry = 15*60+ }
+ Aws/S3/Metadata.hs view
@@ -0,0 +1,9 @@+module Aws.S3.Metadata+where++data S3Metadata+ = S3Metadata {+ s3MAmzId2 :: String+ , s3MRequestId :: String+ }+ deriving (Show)
+ Aws/S3/Model.hs view
@@ -0,0 +1,56 @@+module Aws.S3.Model+where++import Aws.S3.Error+import Control.Monad.Compose.Class+import Data.Time+import Text.XML.Monad+import qualified Text.XML.Light as XL++type CanonicalUserId = String++data UserInfo+ = UserInfo {+ userId :: CanonicalUserId+ , userDisplayName :: String+ }+ deriving (Show)++parseUserInfo :: Xml S3Error XL.Element UserInfo+parseUserInfo = do+ id_ <- strContent <<< findElementNameUI "ID"+ displayName <- strContent <<< findElementNameUI "DisplayName"+ return UserInfo { userId = id_, userDisplayName = displayName }++type Bucket = String++data BucketInfo+ = BucketInfo {+ bucketName :: Bucket+ , bucketCreationDate :: UTCTime+ }+ deriving (Show)++data ObjectInfo+ = ObjectInfo {+ objectKey :: String+ , objectLastModified :: UTCTime+ , objectETag :: String+ , objectSize :: Integer+ , objectStorageClass :: StorageClass+ , objectOwner :: UserInfo+ }+ deriving (Show)++data StorageClass + = StorageClassStandard+ deriving (Show)++type LocationConstraint = String++locationUsClassic, locationUsWest, locationEu, locationApSouthEast, locationApNorthEast :: LocationConstraint+locationUsClassic = ""+locationUsWest = "us-west-1"+locationEu = "EU"+locationApSouthEast = "ap-southeast-1"+locationApNorthEast = "ap-northeast-1"
+ Aws/S3/Query.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}++module Aws.S3.Query+where++import Aws.Credentials+import Aws.Http+import Aws.Query+import Aws.S3.Info+import Aws.Signature+import Aws.Util+import Control.Applicative+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Time+import qualified Blaze.ByteString.Builder as Blaze+import qualified Data.Ascii as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Types as HTTP++data S3Query+ = S3Query {+ s3QBucket :: Maybe A.Ascii+ , s3QSubresources :: HTTP.Query+ , s3QQuery :: HTTP.Query+ }+ deriving (Show)++s3SignQuery :: S3Query -> S3Info -> SignatureData -> SignedQuery+s3SignQuery S3Query{..} S3Info{..} SignatureData{..}+ = SignedQuery {+ sqMethod = method+ , sqProtocol = s3Protocol+ , sqHost = endpointHost s3Endpoint+ , sqPort = s3Port+ , sqPath = path+ , sqQuery = sortedSubresources ++ s3QQuery ++ authQuery+ , sqDate = Just signatureTime+ , sqAuthorization = authorization+ , sqContentType = contentType+ , sqContentMd5 = contentMd5+ , sqBody = L.empty+ , sqStringToSign = stringToSign+ }+ where+ method = Get+ contentMd5 = Nothing+ contentType = Nothing+ path = mconcat . catMaybes $ [Just "/", s3QBucket]+ sortedSubresources = sort s3QSubresources+ canonicalizedResource = A.fromAsciiBuilder . mconcat . catMaybes $+ [ Just $ A.toAsciiBuilder "/"+ , A.toAsciiBuilder <$> s3QBucket+ , Just $ HTTP.renderQueryBuilder True sortedSubresources+ ]+ ti = case (s3UseUri, signatureTimeInfo) of+ (False, ti') -> ti'+ (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time+ (True, AbsoluteExpires time) -> AbsoluteExpires time+ sig = signature signatureCredentials HmacSHA1 stringToSign+ stringToSign = B.intercalate "\n" $ concat [[A.toByteString $ httpMethod method]+ , [fromMaybe "" contentMd5]+ , [fromMaybe "" contentType]+ , [A.toByteString $ case ti of+ AbsoluteTimestamp time -> fmtRfc822Time time+ AbsoluteExpires time -> fmtTimeEpochSeconds time]+ , [] -- canonicalized AMZ headers+ , [A.toByteString canonicalizedResource]]+ (authorization, authQuery) = case ti of+ AbsoluteTimestamp _ -> (Just $ A.unsafeFromByteString $ + B.concat ["AWS ", accessKeyID signatureCredentials, ":", sig], [])+ AbsoluteExpires time -> (Nothing, HTTP.simpleQueryToQuery $ makeAuthQuery time)+ makeAuthQuery time+ = [("Expires", A.toByteString $ fmtTimeEpochSeconds time)+ , ("AWSAccessKeyId", accessKeyID signatureCredentials)+ , ("SignatureMethod", "HmacSHA256")+ , ("Signature", sig)]
+ Aws/S3/Response.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables #-}+module Aws.S3.Response+where++import Aws.Metadata+import Aws.Response+import Aws.S3.Error+import Aws.S3.Metadata+import Aws.Util+import Control.Applicative+import Control.Exception+import Data.Maybe+import qualified Data.Ascii as A+import qualified Data.ByteString as B+import qualified Data.Enumerator as En+import qualified Network.HTTP.Enumerator as HTTP+import qualified Network.HTTP.Types as HTTP++data S3Response a+ = S3Response {+ fromS3Response :: a+ , s3AmzId2 :: String+ , s3RequestId :: String+ }+ deriving (Show)++instance (S3ResponseIteratee a) => ResponseIteratee (S3Response a) where+ responseIteratee status headers = do+ let headerString = fromMaybe "" . fmap A.toString . flip lookup headers+ let amzId2 = headerString "x-amz-id-2"+ let requestId = headerString "x-amz-request-id"+ + specific <- tryError $ s3ResponseIteratee status headers+ + case specific of+ Left (err :: S3Error) -> En.throwError (setMetadata m err)+ where m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId }+ Right resp -> return S3Response {+ fromS3Response = resp+ , s3AmzId2 = amzId2+ , s3RequestId = requestId+ }++class S3ResponseIteratee a where+ s3ResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a++instance S3ResponseIteratee HTTP.Response where+ s3ResponseIteratee = HTTP.lbsIter
+ Aws/Signature.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies, OverloadedStrings #-}+module Aws.Signature+where+ +import Aws.Credentials+import Aws.Query+import Data.Time+import qualified Crypto.HMAC as HMAC+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as Base64+import qualified Data.Serialize as Serialize++data TimeInfo+ = Timestamp+ | ExpiresAt { fromExpiresAt :: UTCTime }+ | ExpiresIn { fromExpiresIn :: NominalDiffTime }+ deriving (Show)++data AbsoluteTimeInfo+ = AbsoluteTimestamp { fromAbsoluteTimestamp :: UTCTime }+ | AbsoluteExpires { fromAbsoluteExpires :: UTCTime }+ deriving (Show)++fromAbsoluteTimeInfo :: AbsoluteTimeInfo -> UTCTime+fromAbsoluteTimeInfo (AbsoluteTimestamp time) = time+fromAbsoluteTimeInfo (AbsoluteExpires time) = time++makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo+makeAbsoluteTimeInfo Timestamp now = AbsoluteTimestamp now+makeAbsoluteTimeInfo (ExpiresAt t) _ = AbsoluteExpires t+makeAbsoluteTimeInfo (ExpiresIn s) now = AbsoluteExpires $ addUTCTime s now++data SignatureData+ = SignatureData {+ signatureTimeInfo :: AbsoluteTimeInfo+ , signatureTime :: UTCTime+ , signatureCredentials :: Credentials+ }++signatureData :: TimeInfo -> Credentials -> IO SignatureData+signatureData rti cr = do+ now <- getCurrentTime+ let ti = makeAbsoluteTimeInfo rti now+ return SignatureData { signatureTimeInfo = ti, signatureTime = now, signatureCredentials = cr }++class SignQuery r where+ type Info r :: *+ signQuery :: r -> Info r -> SignatureData -> SignedQuery++data AuthorizationHash+ = HmacSHA1+ | HmacSHA256+ deriving (Show)++amzHash :: AuthorizationHash -> B.ByteString+amzHash HmacSHA1 = "HmacSHA1"+amzHash HmacSHA256 = "HmacSHA256"++signature :: Credentials -> AuthorizationHash -> B.ByteString -> B.ByteString+signature cr ah input = Base64.encode sig+ where+ sig = case ah of+ HmacSHA1 -> computeSig (undefined :: SHA1.SHA1)+ HmacSHA256 -> computeSig (undefined :: SHA256.SHA256)+ computeSig t = Serialize.encode (HMAC.hmac' key input `asTypeOf` t)+ key = HMAC.MacKey (secretAccessKey cr)
+ Aws/SimpleDb.hs view
@@ -0,0 +1,19 @@+module Aws.SimpleDb+(+ module Aws.SimpleDb.Commands+, module Aws.SimpleDb.Error+, module Aws.SimpleDb.Info+, module Aws.SimpleDb.Metadata+, module Aws.SimpleDb.Model+, module Aws.SimpleDb.Query+, module Aws.SimpleDb.Response+)+where++import Aws.SimpleDb.Commands+import Aws.SimpleDb.Error+import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata+import Aws.SimpleDb.Model+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response
+ Aws/SimpleDb/Commands.hs view
@@ -0,0 +1,25 @@+module Aws.SimpleDb.Commands+(+ module Aws.SimpleDb.Commands.BatchDeleteAttributes+, module Aws.SimpleDb.Commands.BatchPutAttributes+, module Aws.SimpleDb.Commands.CreateDomain+, module Aws.SimpleDb.Commands.DeleteAttributes+, module Aws.SimpleDb.Commands.DeleteDomain+, module Aws.SimpleDb.Commands.DomainMetadata+, module Aws.SimpleDb.Commands.GetAttributes+, module Aws.SimpleDb.Commands.ListDomains+, module Aws.SimpleDb.Commands.PutAttributes+, module Aws.SimpleDb.Commands.Select+)+where++import Aws.SimpleDb.Commands.BatchDeleteAttributes+import Aws.SimpleDb.Commands.BatchPutAttributes+import Aws.SimpleDb.Commands.CreateDomain+import Aws.SimpleDb.Commands.DeleteAttributes+import Aws.SimpleDb.Commands.DeleteDomain+import Aws.SimpleDb.Commands.DomainMetadata+import Aws.SimpleDb.Commands.GetAttributes+import Aws.SimpleDb.Commands.ListDomains+import Aws.SimpleDb.Commands.PutAttributes+import Aws.SimpleDb.Commands.Select
+ Aws/SimpleDb/Commands/BatchDeleteAttributes.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+module Aws.SimpleDb.Commands.BatchDeleteAttributes+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Model+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Aws.Util+import Control.Applicative+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data BatchDeleteAttributes+ = BatchDeleteAttributes {+ bdaItems :: [Item [Attribute DeleteAttribute]]+ , bdaDomainName :: String+ }+ deriving (Show)++data BatchDeleteAttributesResponse+ = BatchDeleteAttributesResponse+ deriving (Show)+ +batchDeleteAttributes :: [Item [Attribute DeleteAttribute]] -> String -> BatchDeleteAttributes+batchDeleteAttributes items domain = BatchDeleteAttributes { bdaItems = items, bdaDomainName = domain }++instance SignQuery BatchDeleteAttributes where+ type Info BatchDeleteAttributes = SdbInfo+ signQuery BatchDeleteAttributes{..}+ = sdbSignQuery $ + [("Action", "BatchDeleteAttributes")+ , ("DomainName", BU.fromString bdaDomainName)] +++ queryList (itemQuery $ queryList (attributeQuery deleteAttributeQuery) "Attribute") "Item" bdaItems++instance SdbFromResponse BatchDeleteAttributesResponse where+ sdbFromResponse = BatchDeleteAttributesResponse <$ testElementNameUI "BatchDeleteAttributesResponse"++instance Transaction BatchDeleteAttributes (SdbResponse BatchDeleteAttributesResponse)
+ Aws/SimpleDb/Commands/BatchPutAttributes.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+module Aws.SimpleDb.Commands.BatchPutAttributes+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Model+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Aws.Util+import Control.Applicative+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data BatchPutAttributes+ = BatchPutAttributes {+ bpaItems :: [Item [Attribute SetAttribute]]+ , bpaDomainName :: String+ }+ deriving (Show)++data BatchPutAttributesResponse+ = BatchPutAttributesResponse+ deriving (Show)+ +batchPutAttributes :: [Item [Attribute SetAttribute]] -> String -> BatchPutAttributes+batchPutAttributes items domain = BatchPutAttributes { bpaItems = items, bpaDomainName = domain }++instance SignQuery BatchPutAttributes where+ type Info BatchPutAttributes = SdbInfo+ signQuery BatchPutAttributes{..}+ = sdbSignQuery $ + [("Action", "BatchPutAttributes")+ , ("DomainName", BU.fromString bpaDomainName)] +++ queryList (itemQuery $ queryList (attributeQuery setAttributeQuery) "Attribute") "Item" bpaItems++instance SdbFromResponse BatchPutAttributesResponse where+ sdbFromResponse = BatchPutAttributesResponse <$ testElementNameUI "BatchPutAttributesResponse"++instance Transaction BatchPutAttributes (SdbResponse BatchPutAttributesResponse)
+ Aws/SimpleDb/Commands/CreateDomain.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+module Aws.SimpleDb.Commands.CreateDomain+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Control.Applicative+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data CreateDomain+ = CreateDomain {+ cdDomainName :: String+ }+ deriving (Show)++data CreateDomainResponse + = CreateDomainResponse+ deriving (Show)+ +createDomain :: String -> CreateDomain+createDomain name = CreateDomain { cdDomainName = name }+ +instance SignQuery CreateDomain where+ type Info CreateDomain = SdbInfo+ signQuery CreateDomain{..} = sdbSignQuery [("Action", "CreateDomain"), ("DomainName", BU.fromString cdDomainName)]++instance SdbFromResponse CreateDomainResponse where+ sdbFromResponse = CreateDomainResponse <$ testElementNameUI "CreateDomainResponse"++instance Transaction CreateDomain (SdbResponse CreateDomainResponse)
+ Aws/SimpleDb/Commands/DeleteAttributes.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+module Aws.SimpleDb.Commands.DeleteAttributes+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Model+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Aws.Util+import Control.Applicative+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data DeleteAttributes+ = DeleteAttributes {+ daItemName :: String+ , daAttributes :: [Attribute DeleteAttribute]+ , daExpected :: [Attribute ExpectedAttribute]+ , daDomainName :: String+ }+ deriving (Show)++data DeleteAttributesResponse+ = DeleteAttributesResponse+ deriving (Show)+ +deleteAttributes :: String -> [Attribute DeleteAttribute] -> String -> DeleteAttributes+deleteAttributes item attributes domain = DeleteAttributes { + daItemName = item+ , daAttributes = attributes+ , daExpected = []+ , daDomainName = domain + }+ +instance SignQuery DeleteAttributes where+ type Info DeleteAttributes = SdbInfo+ signQuery DeleteAttributes{..}+ = sdbSignQuery $ + [("Action", "DeleteAttributes"), ("ItemName", BU.fromString daItemName), ("DomainName", BU.fromString daDomainName)] +++ queryList (attributeQuery deleteAttributeQuery) "Attribute" daAttributes +++ queryList (attributeQuery expectedAttributeQuery) "Expected" daExpected++instance SdbFromResponse DeleteAttributesResponse where+ sdbFromResponse = DeleteAttributesResponse <$ testElementNameUI "DeleteAttributesResponse"++instance Transaction DeleteAttributes (SdbResponse DeleteAttributesResponse)
+ Aws/SimpleDb/Commands/DeleteDomain.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+module Aws.SimpleDb.Commands.DeleteDomain+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Control.Applicative+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data DeleteDomain+ = DeleteDomain {+ ddDomainName :: String+ }+ deriving (Show)++data DeleteDomainResponse+ = DeleteDomainResponse+ deriving (Show)+ +deleteDomain :: String -> DeleteDomain+deleteDomain name = DeleteDomain { ddDomainName = name }+ +instance SignQuery DeleteDomain where+ type Info DeleteDomain = SdbInfo+ signQuery DeleteDomain{..} = sdbSignQuery [("Action", "DeleteDomain"), ("DomainName", BU.fromString ddDomainName)]++instance SdbFromResponse DeleteDomainResponse where+ sdbFromResponse = DeleteDomainResponse <$ testElementNameUI "DeleteDomainResponse"++instance Transaction DeleteDomain (SdbResponse DeleteDomainResponse)
+ Aws/SimpleDb/Commands/DomainMetadata.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+module Aws.SimpleDb.Commands.DomainMetadata+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Control.Applicative+import Control.Monad.Compose.Class+import Data.Time+import Data.Time.Clock.POSIX+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data DomainMetadata+ = DomainMetadata {+ dmDomainName :: String+ }+ deriving (Show)++data DomainMetadataResponse+ = DomainMetadataResponse {+ dmrTimestamp :: UTCTime+ , dmrItemCount :: Integer+ , dmrAttributeValueCount :: Integer+ , dmrAttributeNameCount :: Integer+ , dmrItemNamesSizeBytes :: Integer+ , dmrAttributeValuesSizeBytes :: Integer+ , dmrAttributeNamesSizeBytes :: Integer+ }+ deriving (Show)+ +domainMetadata :: String -> DomainMetadata+domainMetadata name = DomainMetadata { dmDomainName = name }++instance SignQuery DomainMetadata where+ type Info DomainMetadata = SdbInfo+ signQuery DomainMetadata{..} = sdbSignQuery [("Action", "DomainMetadata"), ("DomainName", BU.fromString dmDomainName)]++instance SdbFromResponse DomainMetadataResponse where+ sdbFromResponse = do+ testElementNameUI "DomainMetadataResponse"+ dmrTimestamp <- posixSecondsToUTCTime . fromInteger <$> readContent <<< findElementNameUI "Timestamp"+ dmrItemCount <- readContent <<< findElementNameUI "ItemCount"+ dmrAttributeValueCount <- readContent <<< findElementNameUI "AttributeValueCount"+ dmrAttributeNameCount <- readContent <<< findElementNameUI "AttributeNameCount"+ dmrItemNamesSizeBytes <- readContent <<< findElementNameUI "ItemNamesSizeBytes"+ dmrAttributeValuesSizeBytes <- readContent <<< findElementNameUI "AttributeValuesSizeBytes"+ dmrAttributeNamesSizeBytes <- readContent <<< findElementNameUI "AttributeNamesSizeBytes"+ return DomainMetadataResponse{..}++instance Transaction DomainMetadata (SdbResponse DomainMetadataResponse)
+ Aws/SimpleDb/Commands/GetAttributes.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-}+module Aws.SimpleDb.Commands.GetAttributes+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Model+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Aws.Util+import Control.Applicative+import Control.Monad+import Control.Monad.Compose.Class+import Data.Maybe+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data GetAttributes+ = GetAttributes {+ gaItemName :: String+ , gaAttributeName :: Maybe String+ , gaConsistentRead :: Bool+ , gaDomainName :: String+ }+ deriving (Show)++data GetAttributesResponse+ = GetAttributesResponse {+ garAttributes :: [Attribute String]+ }+ deriving (Show)+ +getAttributes :: String -> String -> GetAttributes+getAttributes item domain = GetAttributes { gaItemName = item, gaAttributeName = Nothing, gaConsistentRead = False, gaDomainName = domain }++instance SignQuery GetAttributes where+ type Info GetAttributes = SdbInfo+ signQuery GetAttributes{..}+ = sdbSignQuery $+ [("Action", "GetAttributes"), ("ItemName", BU.fromString gaItemName), ("DomainName", BU.fromString gaDomainName)] +++ maybeToList (("AttributeName",) <$> BU.fromString <$> gaAttributeName) +++ (guard gaConsistentRead >> [("ConsistentRead", awsTrue)])++instance SdbFromResponse GetAttributesResponse where+ sdbFromResponse = do+ testElementNameUI "GetAttributesResponse"+ attributes <- inList readAttribute <<< findElementsNameUI "Attribute"+ return $ GetAttributesResponse attributes++instance Transaction GetAttributes (SdbResponse GetAttributesResponse)
+ Aws/SimpleDb/Commands/ListDomains.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-}+module Aws.SimpleDb.Commands.ListDomains+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Control.Applicative+import Control.Monad.Compose.Class+import Data.Maybe+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data ListDomains+ = ListDomains {+ ldMaxNumberOfDomains :: Maybe Int+ , ldNextToken :: Maybe String+ }+ deriving (Show)++data ListDomainsResponse + = ListDomainsResponse {+ ldrDomainNames :: [String]+ , ldrNextToken :: Maybe String+ }+ deriving (Show)++listDomains :: ListDomains+listDomains = ListDomains { ldMaxNumberOfDomains = Nothing, ldNextToken = Nothing }+ +instance SignQuery ListDomains where+ type Info ListDomains = SdbInfo+ signQuery ListDomains{..} = sdbSignQuery $ catMaybes [+ Just ("Action", "ListDomains")+ , ("MaxNumberOfDomains",) <$> BU.fromString <$> show <$> ldMaxNumberOfDomains+ , ("NextToken",) <$> BU.fromString <$> ldNextToken+ ]++instance SdbFromResponse ListDomainsResponse where+ sdbFromResponse = do+ testElementNameUI "ListDomainsResponse"+ names <- inList strContent <<< findElementsNameUI "DomainName"+ nextToken <- tryMaybe $ strContent <<< findElementNameUI "NextToken"+ return $ ListDomainsResponse names nextToken++instance Transaction ListDomains (SdbResponse ListDomainsResponse)
+ Aws/SimpleDb/Commands/PutAttributes.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+module Aws.SimpleDb.Commands.PutAttributes+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Model+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Aws.Util+import Control.Applicative+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data PutAttributes+ = PutAttributes {+ paItemName :: String+ , paAttributes :: [Attribute SetAttribute]+ , paExpected :: [Attribute ExpectedAttribute]+ , paDomainName :: String+ }+ deriving (Show)++data PutAttributesResponse+ = PutAttributesResponse+ deriving (Show)+ +putAttributes :: String -> [Attribute SetAttribute] -> String -> PutAttributes+putAttributes item attributes domain = PutAttributes { + paItemName = item+ , paAttributes = attributes+ , paExpected = []+ , paDomainName = domain + }+ +instance SignQuery PutAttributes where+ type Info PutAttributes = SdbInfo+ signQuery PutAttributes{..}+ = sdbSignQuery $ + [("Action", "PutAttributes"), ("ItemName", BU.fromString paItemName), ("DomainName", BU.fromString paDomainName)] +++ queryList (attributeQuery setAttributeQuery) "Attribute" paAttributes +++ queryList (attributeQuery expectedAttributeQuery) "Expected" paExpected++instance SdbFromResponse PutAttributesResponse where+ sdbFromResponse = PutAttributesResponse <$ testElementNameUI "PutAttributesResponse"++instance Transaction PutAttributes (SdbResponse PutAttributesResponse)
+ Aws/SimpleDb/Commands/Select.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+module Aws.SimpleDb.Commands.Select+where++import Aws.Signature+import Aws.SimpleDb.Info+import Aws.SimpleDb.Model+import Aws.SimpleDb.Query+import Aws.SimpleDb.Response+import Aws.Transaction+import Aws.Util+import Control.Monad+import Control.Monad.Compose.Class+import Text.XML.Monad+import qualified Data.ByteString.UTF8 as BU++data Select+ = Select {+ sSelectExpression :: String+ , sConsistentRead :: Bool+ , sNextToken :: String+ }+ deriving (Show)++data SelectResponse+ = SelectResponse {+ srItems :: [Item [Attribute String]]+ , srNextToken :: Maybe String+ }+ deriving (Show)++select :: String -> Select+select expr = Select { sSelectExpression = expr, sConsistentRead = False, sNextToken = "" }++instance SignQuery Select where+ type Info Select = SdbInfo+ signQuery Select{..}+ = sdbSignQuery $+ [("Action", "Select"), ("SelectExpression", BU.fromString sSelectExpression)] +++ (guard sConsistentRead >> [("ConsistentRead", awsTrue)]) +++ (guard (not $ null sNextToken) >> [("NextToken", BU.fromString sNextToken)])++instance SdbFromResponse SelectResponse where+ sdbFromResponse = do+ testElementNameUI "SelectResponse"+ items <- inList readItem <<< findElementsNameUI "Item"+ nextToken <- tryMaybe $ strContent <<< findElementNameUI "NextToken"+ return $ SelectResponse items nextToken++instance Transaction Select (SdbResponse SelectResponse)
+ Aws/SimpleDb/Error.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses #-}+module Aws.SimpleDb.Error+where++import Aws.Metadata+import Aws.SimpleDb.Metadata+import Control.Monad.Error.Class+import Data.Typeable+import Text.XML.Monad+import qualified Control.Exception as C++type ErrorCode = String++data SdbError+ = SdbError {+ sdbStatusCode :: Int+ , sdbErrorCode :: ErrorCode+ , sdbErrorMessage :: String+ , sdbErrorMetadata :: Maybe SdbMetadata+ }+ | SdbXmlError { + fromSdbXmlError :: XmlError+ , sdbXmlErrorMetadata :: Maybe SdbMetadata+ }+ deriving (Show, Typeable)++instance FromXmlError SdbError where+ fromXmlError = flip SdbXmlError Nothing++instance WithMetadata SdbError SdbMetadata where+ getMetadata SdbError { sdbErrorMetadata = err } = err+ getMetadata SdbXmlError { sdbXmlErrorMetadata = err } = err++ setMetadata m e@SdbError{} = e { sdbErrorMetadata = Just m }+ setMetadata m e@SdbXmlError{} = e { sdbXmlErrorMetadata = Just m }++instance Error SdbError where+ noMsg = fromXmlError noMsg+ strMsg = fromXmlError . strMsg++instance C.Exception SdbError
+ Aws/SimpleDb/Info.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+module Aws.SimpleDb.Info+where++import Aws.Http+import qualified Data.Ascii as A++data SdbInfo+ = SdbInfo {+ sdbiProtocol :: Protocol+ , sdbiHttpMethod :: Method+ , sdbiHost :: A.Ascii+ , sdbiPort :: Int+ }+ deriving (Show)+ +sdbUsEast :: A.Ascii+sdbUsEast = "sdb.amazonaws.com" ++sdbUsWest :: A.Ascii+sdbUsWest = "sdb.us-west-1.amazonaws.com"++sdbEuWest :: A.Ascii+sdbEuWest = "sdb.eu-west-1.amazonaws.com"++sdbApSoutheast :: A.Ascii+sdbApSoutheast = "sdb.ap-southeast-1.amazonaws.com"++sdbApNortheast :: A.Ascii+sdbApNortheast = "sdb.ap-northeast-1.amazonaws.com"+ +sdbHttpGet :: A.Ascii -> SdbInfo+sdbHttpGet endpoint = SdbInfo HTTP Get endpoint (defaultPort HTTP)+ +sdbHttpPost :: A.Ascii -> SdbInfo+sdbHttpPost endpoint = SdbInfo HTTP PostQuery endpoint (defaultPort HTTP)+ +sdbHttpsGet :: A.Ascii -> SdbInfo+sdbHttpsGet endpoint = SdbInfo HTTPS Get endpoint (defaultPort HTTPS)+ +sdbHttpsPost :: A.Ascii -> SdbInfo+sdbHttpsPost endpoint = SdbInfo HTTPS PostQuery endpoint (defaultPort HTTPS)
+ Aws/SimpleDb/Metadata.hs view
@@ -0,0 +1,9 @@+module Aws.SimpleDb.Metadata+where++data SdbMetadata + = SdbMetadata {+ requestId :: String+ , boxUsage :: Maybe String+ }+ deriving (Show)
+ Aws/SimpleDb/Model.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+module Aws.SimpleDb.Model+where+ +import Aws.SimpleDb.Error+import Aws.SimpleDb.Response+import Aws.Util+import Control.Monad.Compose.Class+import Text.XML.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as BU+import qualified Text.XML.Light as XL++data Attribute a+ = ForAttribute { attributeName :: String, attributeData :: a }+ deriving (Show)++readAttribute :: Xml SdbError XL.Element (Attribute String)+readAttribute = do+ name <- decodeBase64 <<< findElementNameUI "Name"+ value <- decodeBase64 <<< findElementNameUI "Value"+ return $ ForAttribute name value+ +data SetAttribute+ = SetAttribute { setAttribute :: String, isReplaceAttribute :: Bool }+ deriving (Show)++attributeQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Attribute a -> [(B.ByteString, B.ByteString)]+attributeQuery f (ForAttribute name x) = ("Name", BU.fromString name) : f x+ +addAttribute :: String -> String -> Attribute SetAttribute+addAttribute name value = ForAttribute name (SetAttribute value False)++replaceAttribute :: String -> String -> Attribute SetAttribute+replaceAttribute name value = ForAttribute name (SetAttribute value True)+ +setAttributeQuery :: SetAttribute -> [(B.ByteString, B.ByteString)]+setAttributeQuery (SetAttribute value replace)+ = ("Value", BU.fromString value) : [("Replace", awsTrue) | replace]++data DeleteAttribute+ = DeleteAttribute+ | ValuedDeleteAttribute { deleteAttributeValue :: String }+ deriving (Show)++deleteAttributeQuery :: DeleteAttribute -> [(B.ByteString, B.ByteString)]+deleteAttributeQuery DeleteAttribute = []+deleteAttributeQuery (ValuedDeleteAttribute value) = [("Value", BU.fromString value)]+ +data ExpectedAttribute+ = ExpectedValue { expectedAttributeValue :: String }+ | ExpectedExists { expectedAttributeExists :: Bool }+ deriving (Show)+ +expectedValue :: String -> String -> Attribute ExpectedAttribute+expectedValue name value = ForAttribute name (ExpectedValue value)++expectedExists :: String -> Bool -> Attribute ExpectedAttribute+expectedExists name exists = ForAttribute name (ExpectedExists exists)+ +expectedAttributeQuery :: ExpectedAttribute -> [(B.ByteString, B.ByteString)]+expectedAttributeQuery (ExpectedValue value) = [("Value", BU.fromString value)]+expectedAttributeQuery (ExpectedExists exists) = [("Exists", awsBool exists)]++data Item a+ = Item { itemName :: String, itemData :: a }+ deriving (Show)++readItem :: Xml SdbError XL.Element (Item [Attribute String])+readItem = do+ name <- decodeBase64 <<< findElementNameUI "Name"+ attributes <- inList readAttribute <<< findElementsNameUI "Attribute"+ return $ Item name attributes+ +itemQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Item a -> [(B.ByteString, B.ByteString)]+itemQuery f (Item name x) = ("ItemName", BU.fromString name) : f x
+ Aws/SimpleDb/Query.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+module Aws.SimpleDb.Query+where++import Aws.Credentials+import Aws.Http+import Aws.Query+import Aws.Signature+import Aws.SimpleDb.Info+import Aws.Util+import Data.List+import qualified Data.Ascii as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Types as HTTP++sdbSignQuery :: [(B.ByteString, B.ByteString)] -> SdbInfo -> SignatureData -> SignedQuery+sdbSignQuery q si sd+ = SignedQuery {+ sqMethod = method+ , sqProtocol = sdbiProtocol si+ , sqHost = host+ , sqPort = sdbiPort si+ , sqPath = path+ , sqQuery = sq+ , sqDate = Just $ signatureTime sd+ , sqAuthorization = Nothing+ , sqContentType = Nothing+ , sqContentMd5 = Nothing+ , sqBody = L.empty+ , sqStringToSign = stringToSign+ }+ where+ ah = HmacSHA256+ q' = HTTP.simpleQueryToQuery . sort $ q ++ ("Version", "2009-04-15") : queryAuth+ ti = signatureTimeInfo sd+ cr = signatureCredentials sd+ queryAuth = [case ti of+ AbsoluteTimestamp time -> ("Timestamp", A.toByteString $ fmtAmzTime time)+ AbsoluteExpires time -> ("Expires", A.toByteString $ fmtAmzTime time)+ , ("AWSAccessKeyId", accessKeyID cr)+ , ("SignatureMethod", amzHash ah)+ , ("SignatureVersion", "2")+ ]+ sq = ("Signature", Just sig) : q'+ method = sdbiHttpMethod si+ host = sdbiHost si+ path = "/"+ sig = signature cr ah stringToSign+ stringToSign = B.intercalate "\n" $ map A.toByteString+ [httpMethod method, host, path, HTTP.renderQuery False q']
+ Aws/SimpleDb/Response.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+module Aws.SimpleDb.Response+where++import Aws.Metadata+import Aws.Response+import Aws.SimpleDb.Error+import Aws.SimpleDb.Metadata+import Control.Applicative+import Control.Arrow ((+++))+import Control.Monad.Compose.Class+import Control.Monad.Reader.Class+import Data.Char+import Text.XML.Monad+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.UTF8 as BU+import qualified Network.HTTP.Enumerator as HTTP+import qualified Text.XML.Light as XL++data SdbResponse a+ = SdbResponse { + fromSdbResponse :: a+ , sdbResponseMetadata :: SdbMetadata+ }+ deriving (Show)++instance Functor SdbResponse where+ fmap f (SdbResponse a m) = SdbResponse (f a) m++instance (SdbFromResponse a) => ResponseIteratee (SdbResponse a) where+ responseIteratee = xmlResponseIteratee $ do+ status <- asks HTTP.statusCode+ fromXml status <<< parseXmlResponse+ where fromXml :: SdbFromResponse a => Int -> Xml SdbError XL.Element (SdbResponse a)+ fromXml status = do+ requestId' <- strContent <<< findElementNameUI "RequestID"+ boxUsage' <- tryMaybe $ strContent <<< findElementNameUI "BoxUsage"+ let metadata = SdbMetadata requestId' boxUsage'+ innerTry <- try $ fromXmlInner status+ inner <- case innerTry of+ Left err -> raise $ setMetadata metadata err+ Right response -> return response+ return $ SdbResponse inner metadata+ fromXmlInner :: SdbFromResponse a => Int -> Xml SdbError XL.Element a+ fromXmlInner status = do+ xmlError <- tryMaybe $ findElementNameUI "Error"+ case xmlError of+ Just err -> mapply (fromError status) err+ Nothing -> sdbFromResponse+ fromError :: Int -> Xml SdbError XL.Element a+ fromError status = do+ errCode <- strContent <<< findElementNameUI "Code"+ errMessage <- strContent <<< findElementNameUI "Message"+ raise $ SdbError status errCode errMessage Nothing++class SdbFromResponse a where+ sdbFromResponse :: Xml SdbError XL.Element a++decodeBase64 :: Xml SdbError XL.Element String+decodeBase64 = do+ encoded <- strContent+ encoding <- tryMaybe $ findAttr (XL.unqual "encoding")+ raisesXml $ case map toLower <$> encoding of+ Nothing -> Right encoded+ Just "base64" -> (EncodingError . ("Invalid Base64 data: "++) +++ BU.toString) . Base64.decode . BU.fromString $ encoded+ Just actual -> Left $ UnexpectedAttributeValueQ actual "base64"
+ Aws/Transaction.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+module Aws.Transaction+where+ +import Aws.Response+import Aws.Signature++class (SignQuery r, ResponseIteratee a)+ => Transaction r a | r -> a, a -> r
+ Aws/Util.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++module Aws.Util+where+ +import Control.Arrow+import Control.Exception+import Data.Time+import System.Locale+import qualified Data.Ascii as A+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as BU+import qualified Data.Enumerator as En++tryError :: (Exception e, Monad m) => En.Iteratee a m b -> En.Iteratee a m (Either e b)+tryError m = En.catchError (fmap Right m) h+ where h e = case fromException e of+ Just v -> return $ Left v+ Nothing -> En.throwError e++queryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> [(B.ByteString, B.ByteString)]+queryList f prefix xs = concat $ zipWith combine prefixList (map f xs)+ where prefixList = map (dot prefix . BU.fromString . show) [(1 :: Int) ..]+ combine pf = map $ first (pf `dot`)+ dot x y = B.concat [x, BU.fromString ".", y]++awsBool :: Bool -> B.ByteString+awsBool True = "true"+awsBool False = "false"++awsTrue :: B.ByteString+awsTrue = awsBool True++awsFalse :: B.ByteString+awsFalse = awsBool False++fmtTime :: String -> UTCTime -> A.Ascii+fmtTime s t = A.unsafeFromString $ formatTime defaultTimeLocale s t++fmtRfc822Time :: UTCTime -> A.Ascii+fmtRfc822Time = fmtTime "%a, %_d %b %Y %H:%M:%S GMT"++fmtAmzTime :: UTCTime -> A.Ascii+fmtAmzTime = fmtTime "%Y-%m-%dT%H:%M:%S"++fmtTimeEpochSeconds :: UTCTime -> A.Ascii+fmtTimeEpochSeconds = fmtTime "%s"
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2010, Aristid Breitkreuz++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 Aristid Breitkreuz 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.
+ README view
@@ -0,0 +1,1 @@+Amazon Web Services for Haskell
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aws.cabal view
@@ -0,0 +1,125 @@+-- aws.cabal auto-generated by cabal init. For additional options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: aws++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.0.1++-- A short (one-line) description of the package.+Synopsis: Amazon Web Services (AWS) for Haskell++-- A longer description of the package.+Description: Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services.++-- URL for the project homepage or repository.+Homepage: http://github.com/aristidb/aws++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Aristid Breitkreuz++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: aristidb@googlemail.com++-- A copyright notice.+Copyright: Copyright (C) 2010 Aristid Breitkreuz++Category: Web++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files: README++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.8+++Library+ -- Modules exported by the library.+ Exposed-modules:+ Aws,+ Aws.Aws,+ Aws.Credentials,+ Aws.Debug,+ Aws.Http,+ Aws.Metadata,+ Aws.Query,+ Aws.Response,+ Aws.S3,+ Aws.S3.Commands,+ Aws.S3.Commands.GetBucket,+ Aws.S3.Commands.GetService,+ Aws.S3.Error,+ Aws.S3.Info,+ Aws.S3.Metadata,+ Aws.S3.Model,+ Aws.S3.Query,+ Aws.S3.Response,+ Aws.Signature,+ Aws.SimpleDb,+ Aws.SimpleDb.Commands,+ Aws.SimpleDb.Commands.BatchDeleteAttributes,+ Aws.SimpleDb.Commands.BatchPutAttributes,+ Aws.SimpleDb.Commands.CreateDomain,+ Aws.SimpleDb.Commands.DeleteAttributes,+ Aws.SimpleDb.Commands.DeleteDomain,+ Aws.SimpleDb.Commands.DomainMetadata,+ Aws.SimpleDb.Commands.GetAttributes,+ Aws.SimpleDb.Commands.ListDomains,+ Aws.SimpleDb.Commands.PutAttributes,+ Aws.SimpleDb.Commands.Select,+ Aws.SimpleDb.Error,+ Aws.SimpleDb.Info,+ Aws.SimpleDb.Metadata,+ Aws.SimpleDb.Model,+ Aws.SimpleDb.Query,+ Aws.SimpleDb.Response,+ Aws.Transaction,+ Aws.Util+ + -- Packages needed in order to build this package.+ Build-depends:+ ascii >=0.0.2 && <0.1,+ base ==4.*,+ base64-bytestring ==0.1.*,+ blaze-builder >=0.2.1.4 && <0.3,+ bytestring ==0.9.*,+ cereal ==0.3.*,+ containers ==0.3.*,+ crypto-api ==0.5.*,+ cryptohash ==0.6.*,+ directory ==1.0.*,+ enumerator ==0.4.*,+ filepath ==1.1.*,+ http-enumerator >=0.4.0.1 && < 0.5,+ http-types >=0.5.3 && <0.6,+ mtl ==2.*,+ old-locale ==1.*,+ shortcircuit ==0.1.*,+ time >=1.1.4 && <1.3,+ transformers >=0.2.2.0 && <0.3,+ transformers-compose ==0.1.*,+ utf8-string ==0.3.*,+ wai >=0.3.1 && <0.4,+ xml ==1.3.*,+ xml-monad >=0.5 && <0.6++ GHC-Options: -Wall+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +